From 629f20c2d34201ae3211e398066b1a72dceb127e Mon Sep 17 00:00:00 2001 From: Brooklyn Zelenka Date: Sat, 18 Sep 2021 14:58:33 -0700 Subject: [PATCH] Generalize Mock to work with CLI (#554) --- fission-core/library/Fission/Internal/Mock.hs | 26 ++ .../library/Fission/Internal/Mock/Effect.hs | 13 + .../Fission/Internal/Mock/Effect/Types.hs | 43 +++ .../Fission/Internal}/Mock/Session/Types.hs | 3 +- .../library/Fission/Internal/Mock/Types.hs | 99 ++++++ fission-core/package.yaml | 7 +- .../library/Fission/Web/Server/Auth/Class.hs | 34 +- .../Web/Server/Auth/Token/Basic/Class.hs | 21 +- .../library/Fission/Web/Server/Mock.hs | 38 --- .../library/Fission/Web/Server/Mock/Effect.hs | 23 -- .../Fission/Web/Server/Mock/Effect/Types.hs | 83 +---- .../library/Fission/Web/Server/Mock/Types.hs | 310 ------------------ fission-web-server/package.yaml | 4 - .../test/Fission/Test/Web/Server/Auth.hs | 20 +- .../Web/Server/Auth/Token/JWT/Validation.hs | 6 +- .../Web/Server/Auth/Token/UCAN/Resource.hs | 1 - .../test/Fission/Test/Web/Server/Error.hs | 4 +- .../test/Fission/Test/Web/Server/Prelude.hs | 3 - .../test/Fission/Test/Web/Server/Root.hs | 5 +- 19 files changed, 273 insertions(+), 470 deletions(-) create mode 100644 fission-core/library/Fission/Internal/Mock.hs create mode 100644 fission-core/library/Fission/Internal/Mock/Effect.hs create mode 100644 fission-core/library/Fission/Internal/Mock/Effect/Types.hs rename {fission-web-server/library/Fission/Web/Server => fission-core/library/Fission/Internal}/Mock/Session/Types.hs (62%) create mode 100644 fission-core/library/Fission/Internal/Mock/Types.hs delete mode 100644 fission-web-server/library/Fission/Web/Server/Mock.hs delete mode 100644 fission-web-server/library/Fission/Web/Server/Mock/Effect.hs delete mode 100644 fission-web-server/library/Fission/Web/Server/Mock/Types.hs diff --git a/fission-core/library/Fission/Internal/Mock.hs b/fission-core/library/Fission/Internal/Mock.hs new file mode 100644 index 000000000..85db60c81 --- /dev/null +++ b/fission-core/library/Fission/Internal/Mock.hs @@ -0,0 +1,26 @@ +module Fission.Internal.Mock + ( module Fission.Internal.Mock.Types + , module Fission.Internal.Mock.Effect + , runMock + , runMockIO + ) where + +import Control.Monad.Writer (runWriterT) + +import Fission.Prelude + +import Fission.Internal.Mock.Effect +import Fission.Internal.Mock.Types as Mock + +-- Reexports + +import Fission.Internal.Mock.Types + +-- | Run the action described by a @Mock@ +runMock :: forall effs cfg m a . MonadIO m => cfg -> Mock effs cfg a -> m (Mock.Session effs a) +runMock cfg (Mock action) = toSession <$> runRIO cfg (runWriterT action) + where + toSession = \(result, effectLog) -> Mock.Session {..} + +runMockIO :: MonadIO m => cfg -> Mock effs cfg a -> m a +runMockIO cfg (Mock action) = fst <$> runRIO cfg (runWriterT action) diff --git a/fission-core/library/Fission/Internal/Mock/Effect.hs b/fission-core/library/Fission/Internal/Mock/Effect.hs new file mode 100644 index 000000000..e774f924e --- /dev/null +++ b/fission-core/library/Fission/Internal/Mock/Effect.hs @@ -0,0 +1,13 @@ +module Fission.Internal.Mock.Effect + ( log + , module Fission.Internal.Mock.Effect.Types + ) where + +import Control.Monad.Writer + +import Fission.Prelude hiding (log) + +import Fission.Internal.Mock.Effect.Types + +log :: (IsMember eff log, Applicative t, MonadWriter (t (OpenUnion log)) m) => eff -> m () +log effect = tell . pure $ openUnionLift effect diff --git a/fission-core/library/Fission/Internal/Mock/Effect/Types.hs b/fission-core/library/Fission/Internal/Mock/Effect/Types.hs new file mode 100644 index 000000000..f6343d803 --- /dev/null +++ b/fission-core/library/Fission/Internal/Mock/Effect/Types.hs @@ -0,0 +1,43 @@ +module Fission.Internal.Mock.Effect.Types + ( RunIO (..) + , RunThrow (..) + , RunCatch (..) + , GetTime (..) + , LogMsg (..) + , RunLocalIPFS (..) + , RunRemoteIPFS (..) + ) where + +import Control.Monad.Logger as Logger +import qualified Network.IPFS.Types as IPFS + +import Fission.Prelude + +import qualified RIO.ByteString.Lazy as Lazy + +data RunIO = RunIO + deriving (Eq, Show) + +data RunThrow = RunThrow + deriving (Eq, Show) + +data RunCatch = RunCatch + deriving (Eq, Show) + +data GetTime = GetTime + deriving (Eq, Show) + +data LogMsg = LogMsg Logger.LogLevel LogStr + deriving (Eq, Show) + +data RunLocalIPFS = RunLocalIPFS + deriving (Eq, Show) + +data RunRemoteIPFS + = RemoteIPFSGeneric + | RemoteIPFSAdd Lazy.ByteString + | RemoteIPFSCat IPFS.CID + | RemoteIPFSPin IPFS.CID + | RemoteIPFSUnpin IPFS.CID Bool + deriving (Eq, Show) + diff --git a/fission-web-server/library/Fission/Web/Server/Mock/Session/Types.hs b/fission-core/library/Fission/Internal/Mock/Session/Types.hs similarity index 62% rename from fission-web-server/library/Fission/Web/Server/Mock/Session/Types.hs rename to fission-core/library/Fission/Internal/Mock/Session/Types.hs index 6240fc984..424a8c41b 100644 --- a/fission-web-server/library/Fission/Web/Server/Mock/Session/Types.hs +++ b/fission-core/library/Fission/Internal/Mock/Session/Types.hs @@ -1,5 +1,4 @@ --- NB: move all of this stuff to /library. Seems pretty useful for local dev, too! -module Fission.Web.Server.Mock.Session.Types (Session (..)) where +module Fission.Internal.Mock.Session.Types (Session (..)) where import Fission.Prelude diff --git a/fission-core/library/Fission/Internal/Mock/Types.hs b/fission-core/library/Fission/Internal/Mock/Types.hs new file mode 100644 index 000000000..e499c794e --- /dev/null +++ b/fission-core/library/Fission/Internal/Mock/Types.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Fission.Internal.Mock.Types + ( module Fission.Internal.Mock.Effect.Types + , module Fission.Internal.Mock.Session.Types + , Mock (..) + ) where + +import Control.Monad.Catch as Catch +import Control.Monad.Logger +import Control.Monad.Time +import Control.Monad.Writer + +import Servant.Client.Core + +import qualified Network.IPFS.Client.Pin as Network.Pin +import qualified Network.IPFS.File.Types as File +import Network.IPFS.Remote.Class +import qualified Network.IPFS.Types as IPFS + +import Fission.Prelude + +import qualified Fission.Internal.Mock.Effect as Effect + +-- Reexport + +import Fission.Internal.Mock.Effect.Types +import Fission.Internal.Mock.Session.Types + +{- | Fission's mock type + + Notes: + * We will likely want @State@ in here at some stage + * @RIO@ because lots of constraints want @MonadIO@ + * Avoid actual @IO@, or we're going to have to rework this 😉 + +-} +newtype Mock effs cfg a = Mock + { unMock :: WriterT [OpenUnion effs] (RIO cfg) a } + deriving + newtype ( Functor + , Applicative + , Monad + , MonadWriter [OpenUnion effs] + , MonadReader cfg + ) + +instance RunIO `IsMember` effs => MonadIO (Mock effs cfg) where + liftIO action = do + Effect.log RunIO + Mock $ liftIO action + +instance RunThrow `IsMember` effs => MonadThrow (Mock effs cfg) where + throwM err = do + Effect.log RunThrow + Mock $ throwM err + +instance (RunThrow `IsMember` effs, RunCatch `IsMember` effs) => MonadCatch (Mock effs cfg) where + catch action handler = do + Effect.log RunCatch + Mock $ Catch.catch (unMock action) (unMock . handler) + +instance (GetTime `IsMember` effs, HasField' "now" cfg UTCTime) => MonadTime (Mock effs cfg) where + currentTime = do + Effect.log GetTime + asks $ getField @"now" + +instance LogMsg `IsMember` effs => MonadLogger (Mock effs cfg) where + monadLoggerLog _loc _src lvl msg = + Effect.log . LogMsg lvl $ toLogStr msg + +instance + ( RunIO `IsMember` effs + , RunRemoteIPFS `IsMember` effs + , HasField' "remoteIPFSAdd" cfg (Either ClientError IPFS.CID) + , HasField' "remoteIPFSCat" cfg (Either ClientError File.Serialized) + , HasField' "remoteIPFSPin" cfg (Either ClientError Network.Pin.Response) + , HasField' "remoteIPFSUnpin" cfg (Either ClientError Network.Pin.Response) + ) + => MonadRemoteIPFS (Mock effs cfg) where + runRemote _ = do + Effect.log RemoteIPFSGeneric + error "Directly called runRemote" + + ipfsAdd bs = do + Effect.log $ RemoteIPFSAdd bs + asks $ getField @"remoteIPFSAdd" + + ipfsCat cid = do + Effect.log $ RemoteIPFSCat cid + asks $ getField @"remoteIPFSCat" + + ipfsPin cid = do + Effect.log $ RemoteIPFSPin cid + asks $ getField @"remoteIPFSPin" + + ipfsUnpin cid flag = do + Effect.log $ RemoteIPFSUnpin cid flag + asks $ getField @"remoteIPFSUnpin" diff --git a/fission-core/package.yaml b/fission-core/package.yaml index 15e1ce706..6c81148d2 100644 --- a/fission-core/package.yaml +++ b/fission-core/package.yaml @@ -1,5 +1,5 @@ name: fission-core -version: '3.3.0.0' +version: '3.4.0.0' category: API author: - Brooklyn Zelenka @@ -98,6 +98,7 @@ dependencies: - monad-control - monad-logger - monad-time + - mtl ## Command Line ## - envy @@ -164,10 +165,6 @@ tests: source-dirs: - library - test - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N dependencies: - base58string - binary diff --git a/fission-web-server/library/Fission/Web/Server/Auth/Class.hs b/fission-web-server/library/Fission/Web/Server/Auth/Class.hs index 44b61c789..eee030938 100644 --- a/fission-web-server/library/Fission/Web/Server/Auth/Class.hs +++ b/fission-web-server/library/Fission/Web/Server/Auth/Class.hs @@ -1,10 +1,40 @@ -module Fission.Web.Server.Auth.Class (MonadAuth (..)) where +{-# LANGUAGE UndecidableInstances #-} -import Network.Wai +module Fission.Web.Server.Auth.Class + ( MonadAuth (..) + , GetAuthVerifier (..) + ) where + +import Network.Wai as Wai import Servant.Server.Experimental.Auth import Fission.Prelude +import Fission.Internal.Mock as Effect +import Fission.User.DID.Types + +import Fission.Web.Server.Authorization.Types +import Fission.Web.Server.Mock.Config as Mock +import Fission.Web.Server.Models + class Monad m => MonadAuth who m where -- | Check that some entity is authenticated and authorized getVerifier :: m (AuthHandler Request who) + +data GetAuthVerifier a = GetAuthVerifier + deriving (Eq, Show) + +instance GetAuthVerifier DID `IsMember` effs => MonadAuth DID (Mock effs Mock.Config) where + getVerifier = do + Effect.log $ GetAuthVerifier @DID + asks didVerifier + +instance GetAuthVerifier (Entity User) `IsMember` effs => MonadAuth (Entity User) (Mock effs Mock.Config) where + getVerifier = do + Effect.log $ GetAuthVerifier @(Entity User) + asks userVerifier + +instance GetAuthVerifier Authorization `IsMember` effs => MonadAuth Authorization (Mock effs Mock.Config) where + getVerifier = do + Effect.log $ GetAuthVerifier @Authorization + asks authVerifier diff --git a/fission-web-server/library/Fission/Web/Server/Auth/Token/Basic/Class.hs b/fission-web-server/library/Fission/Web/Server/Auth/Token/Basic/Class.hs index 58e04d024..a4a1fc773 100644 --- a/fission-web-server/library/Fission/Web/Server/Auth/Token/Basic/Class.hs +++ b/fission-web-server/library/Fission/Web/Server/Auth/Token/Basic/Class.hs @@ -1,9 +1,26 @@ -module Fission.Web.Server.Auth.Token.Basic.Class (MonadBasicAuth (..)) where +{-# LANGUAGE UndecidableInstances #-} -import Servant +module Fission.Web.Server.Auth.Token.Basic.Class + ( MonadBasicAuth (..) + , GetBasicAuth (..) + ) where + +import Servant (BasicAuthCheck) import Fission.Prelude +import Fission.Internal.Mock as Effect +import qualified Fission.Web.API.Heroku.Auth.Types as Heroku +import Fission.Web.Server.Mock.Config as Mock + class Monad m => MonadBasicAuth who m where -- | Check that some entity is authenticated and authorized getVerifier :: m (BasicAuthCheck who) + +data GetBasicAuth who = GetBasicAuth + deriving (Eq, Show) + +instance forall effs . GetBasicAuth Heroku.Auth `IsMember` effs => MonadBasicAuth Heroku.Auth (Mock effs Mock.Config) where + getVerifier = do + Effect.log $ GetBasicAuth @Heroku.Auth + asks herokuVerifier diff --git a/fission-web-server/library/Fission/Web/Server/Mock.hs b/fission-web-server/library/Fission/Web/Server/Mock.hs deleted file mode 100644 index dca364b74..000000000 --- a/fission-web-server/library/Fission/Web/Server/Mock.hs +++ /dev/null @@ -1,38 +0,0 @@ -module Fission.Web.Server.Mock - ( module Fission.Web.Server.Mock.Types - , module Fission.Web.Server.Mock.Effect - , module Fission.Web.Server.Mock.Config - , runMock - , runMockIO' - , runMockIO - ) where - -import Control.Monad.Writer (runWriterT) - -import Fission.Prelude - -import Fission.Web.Server.Mock.Types -import Fission.Web.Server.Mock.Types as Mock - -import Fission.Web.Server.Mock.Config -import Fission.Web.Server.Mock.Effect - --- | Run the action described by a @Mock@ -runMock :: forall effs m a . MonadIO m => Mock.Config -> Mock effs a -> m (Mock.Session effs a) -runMock cfg action = do - action - |> unMock - |> runWriterT - |> runRIO cfg - |> fmap \(result, effectLog) -> Mock.Session {..} - -runMockIO' :: Mock effs a -> IO a -runMockIO' = runMockIO defaultConfig - -runMockIO :: MonadIO m => Mock.Config -> Mock effs a -> m a -runMockIO cfg action = do - action - |> unMock - |> runWriterT - |> runRIO cfg - |> fmap fst diff --git a/fission-web-server/library/Fission/Web/Server/Mock/Effect.hs b/fission-web-server/library/Fission/Web/Server/Mock/Effect.hs deleted file mode 100644 index a4d54f0de..000000000 --- a/fission-web-server/library/Fission/Web/Server/Mock/Effect.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Fission.Web.Server.Mock.Effect - ( module Fission.Web.Server.Mock.Effect.Types - , log - ) where - -import Control.Monad.Writer - -import Fission.Prelude hiding (log) - -import Fission.Web.Server.Mock.Effect.Types - -log :: - ( IsMember eff log - , Applicative t - , MonadWriter (t (OpenUnion log)) m - ) - => eff - -> m () -log effect = - effect - |> openUnionLift - |> pure - |> tell diff --git a/fission-web-server/library/Fission/Web/Server/Mock/Effect/Types.hs b/fission-web-server/library/Fission/Web/Server/Mock/Effect/Types.hs index 08fa618ff..4496afb18 100644 --- a/fission-web-server/library/Fission/Web/Server/Mock/Effect/Types.hs +++ b/fission-web-server/library/Fission/Web/Server/Mock/Effect/Types.hs @@ -1,14 +1,10 @@ module Fission.Web.Server.Mock.Effect.Types ( RunDB (..) - , CheckTime (..) , RunAWS (..) , UpdateRoute53 (..) , ClearRoute53 (..) , SetDNSLink (..) , FollowDNSLink (..) - , RunLocalIPFS (..) - , RunRemoteIPFS (..) - , LogMsg (..) , CreateHerokuAddOn (..) , DestroyHerokuAddOn (..) , RetrieveUser (..) @@ -18,7 +14,6 @@ module Fission.Web.Server.Mock.Effect.Types , RetrieveLoosePin (..) , CreateLoosePin (..) , DestroyLoosePin (..) - , FissionEffs ) where import qualified Network.IPFS.Types as IPFS @@ -37,78 +32,28 @@ import Fission.User.Username.Types import Fission.Web.Server.Models -type FissionEffs = - '[ CheckTime - , RunAWS - , RunDB - , SetDNSLink - , FollowDNSLink - , UpdateRoute53 - , ClearRoute53 - , RunLocalIPFS - , RunRemoteIPFS - , LogMsg - , DestroyHerokuAddOn - , DestroyUser - , DestroyLoosePin - , RetrieveUser - , RetrieveLoosePin - , ModifyUser - , CreateUser - , CreateLoosePin - , CreateHerokuAddOn - ] - -data RunDB - = RunDB +data RunDB = RunDB deriving (Eq, Show) -data CheckTime - = CheckTime +data RunAWS = RunAWS deriving (Eq, Show) -data RunAWS - = RunAWS +data UpdateRoute53 = UpdateRoute53 deriving (Eq, Show) -data UpdateRoute53 - = UpdateRoute53 +data ClearRoute53 = ClearRoute53 deriving (Eq, Show) -data ClearRoute53 - = ClearRoute53 +data SetDNSLink = SetDNSLink deriving (Eq, Show) -data SetDNSLink - = SetDNSLink +data FollowDNSLink = FollowDNSLink URL (Path URL) deriving (Eq, Show) -data FollowDNSLink - = FollowDNSLink URL (Path URL) +data DestroyHerokuAddOn = DestroyHerokuAddOn UUID deriving (Eq, Show) -data RunLocalIPFS - = RunLocalIPFS - deriving (Eq, Show) - -data RunRemoteIPFS - = RemoteIPFSGeneric - | RemoteIPFSAdd Lazy.ByteString - | RemoteIPFSCat IPFS.CID - | RemoteIPFSPin IPFS.CID - | RemoteIPFSUnpin IPFS.CID Bool - deriving (Eq, Show) - -data LogMsg - = LogMsg LogLevel LogStr - deriving (Eq, Show) - -data DestroyHerokuAddOn - = DestroyHerokuAddOn UUID - deriving (Eq, Show) - -data CreateHerokuAddOn - = CreateHerokuAddOn UUID +data CreateHerokuAddOn = CreateHerokuAddOn UUID deriving (Eq, Show) data RetrieveUser @@ -119,16 +64,13 @@ data RetrieveUser | GetUserById UserId deriving (Eq, Show) -data CreateUser - = CreateUser +data CreateUser = CreateUser deriving (Eq, Show) -data ModifyUser - = ModifyUser UserId +data ModifyUser = ModifyUser UserId deriving (Eq, Show) -data DestroyUser - = DestroyUser UserId +data DestroyUser = DestroyUser UserId deriving (Eq, Show) data RetrieveLoosePin @@ -136,8 +78,7 @@ data RetrieveLoosePin | GetLoosePinByCID IPFS.CID deriving (Eq, Show) -data CreateLoosePin - = CreateLoosePin UserId IPFS.CID +data CreateLoosePin = CreateLoosePin UserId IPFS.CID deriving (Eq, Show) data DestroyLoosePin diff --git a/fission-web-server/library/Fission/Web/Server/Mock/Types.hs b/fission-web-server/library/Fission/Web/Server/Mock/Types.hs deleted file mode 100644 index b4687df44..000000000 --- a/fission-web-server/library/Fission/Web/Server/Mock/Types.hs +++ /dev/null @@ -1,310 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} - -module Fission.Web.Server.Mock.Types - ( module Fission.Web.Server.Mock.Config.Types - , module Fission.Web.Server.Mock.Effect.Types - , module Fission.Web.Server.Mock.Session.Types - , Mock (..) - ) where - -import Control.Monad.Catch -import Control.Monad.Trans.AWS -import Control.Monad.Writer - -import Database.Esqueleto as Database - -import Network.IPFS.Remote.Class -import qualified Network.IPFS.Types as IPFS - -import Network.AWS - -import Servant.Client -import Servant.Server - -import Fission.Prelude - -import qualified Fission.Internal.Fixture.Time as Fixture -import Fission.URL -import Fission.User.DID.Types - -import qualified Fission.Web.API.Heroku.Auth.Types as Heroku -import qualified Fission.Web.API.Host.Types as Web - -import Fission.Web.Server.Authorization.Types -import Fission.Web.Server.Mock.Config.Types as Mock -import Fission.Web.Server.Mock.Effect as Effect -import Fission.Web.Server.Mock.Session.Types - -import Fission.Web.Server.IPFS.DNSLink.Class -import Fission.Web.Server.IPFS.Linked.Class - -import Fission.Web.Server.Auth.Class -import Fission.Web.Server.Models -import Fission.Web.Server.Reflective.Class - -import Fission.Web.Server.Auth.Token.Basic.Class - -import Fission.Web.Server.AWS -import Fission.Web.Server.Heroku.AddOn as Heroku.AddOn -import Fission.Web.Server.LoosePin as LoosePin -import Fission.Web.Server.MonadDB -import Fission.Web.Server.User as User - -import qualified Fission.Web.Server.Fixture.Entity as Fixture -import qualified Fission.Web.Server.Fixture.User as Fixture - --- Reexport - -import Fission.Web.Server.Mock.Config.Types -import Fission.Web.Server.Mock.Effect.Types - -{- | Fission's mock type - - Notes: - * We will likely want @State@ in here at some stage - * @RIO@ because lots of constraints want @MonadIO@ - * Avoid actual @IO@, or we're going to have to rework this 😉 - --} -newtype Mock effs a = Mock - { unMock :: WriterT [OpenUnion effs] (RIO Mock.Config) a } - deriving - newtype ( Functor - , Applicative - , Monad - , MonadWriter [OpenUnion effs] - , MonadReader Mock.Config - , MonadIO - , MonadThrow - , MonadCatch - ) - -instance IsMember RunDB effs => MonadDB (Mock effs) (Mock effs) where - runDB transaction = do - Effect.log RunDB - transaction - -instance MonadLinkedIPFS (Mock effs) where - getLinkedPeers = do - peerList <- asks linkedPeers - return peerList - -instance MonadBasicAuth String (Mock effs) where - getVerifier = do - isAuthed <- asks forceAuthed - return $ BasicAuthCheck \_ -> - return if isAuthed - then Authorized "YUP" - else Unauthorized - -instance MonadBasicAuth Heroku.Auth (Mock effs) where - getVerifier = asks herokuVerifier - -instance MonadAuth DID (Mock effs) where - getVerifier = asks didVerifier - -instance MonadAuth (Entity User) (Mock effs) where - getVerifier = asks userVerifier - -instance MonadAuth Authorization (Mock effs) where - getVerifier = asks authVerifier - -instance IsMember RunAWS effs => MonadAWS (Mock effs) where - liftAWS awsAction = do - Effect.log RunAWS - env <- newEnv $ FromKeys "FAKE_ACCESS_KEY" "FAKE_SECRET_KEY" - liftIO . runResourceT $ runAWST env awsAction - -instance IsMember CheckTime effs => MonadTime (Mock effs) where - currentTime = do - Effect.log CheckTime - asks now - -instance - ( IsMember RunAWS effs - , IsMember UpdateRoute53 effs - , IsMember ClearRoute53 effs - ) - => MonadRoute53 (Mock effs) where - set r url zone nonEmptyTxts ttl = do - Effect.log UpdateRoute53 - runner <- asks updateRoute53 - return $ runner r url zone nonEmptyTxts ttl - - clear url _ = do - Effect.log ClearRoute53 - runner <- asks clearRoute53 - return $ runner url - - get url zone = do - runner <- asks getRoute53 - return $ runner url zone - -instance - ( IsMember UpdateRoute53 effs - , IsMember ClearRoute53 effs - , IsMember SetDNSLink effs - , IsMember FollowDNSLink effs - , IsMember RunAWS effs - ) - => MonadDNSLink (Mock effs) where - set _userID URL {..} _ cid = do - Effect.log SetDNSLink - runner <- asks setDNSLink - return $ runner domainName subdomain cid - - follow _userID toSet _ toFollow = do - Effect.log $ FollowDNSLink toSet toFollow - runner <- asks followDNSLink - return $ runner toSet toFollow - -instance IsMember RunRemoteIPFS effs => MonadRemoteIPFS (Mock effs) where - runRemote _ = do - Effect.log RemoteIPFSGeneric - error "Directly called runRemote" - - ipfsAdd bs = do - Effect.log $ RemoteIPFSAdd bs - asks remoteIPFSAdd - - ipfsCat cid = do - Effect.log $ RemoteIPFSCat cid - asks remoteIPFSCat - - ipfsPin cid = do - Effect.log $ RemoteIPFSPin cid - asks remoteIPFSPin - - ipfsUnpin cid flag = do - Effect.log $ RemoteIPFSUnpin cid flag - asks remoteIPFSUnpin - -instance MonadReflectiveServer (Mock effs) where - getHost = Web.Host <$> parseBaseUrl "example.com" - -instance IsMember LogMsg effs => MonadLogger (Mock effs) where - monadLoggerLog _loc _src lvl msg = do - Effect.log . LogMsg lvl $ toLogStr msg - -instance IsMember DestroyHerokuAddOn effs => Heroku.AddOn.Destroyer (Mock effs) where - destroyByUUID uuid = do - Effect.log $ DestroyHerokuAddOn uuid - pure () - -instance IsMember DestroyHerokuAddOn effs => Heroku.AddOn.Retriever (Mock effs) where - getByUUID uuid = do - Effect.log $ DestroyHerokuAddOn uuid - return Nothing - -instance IsMember CreateHerokuAddOn effs => Heroku.AddOn.Creator (Mock effs) where - create uuid _ _ = do - Effect.log $ CreateHerokuAddOn uuid - return . Right $ Database.toSqlKey 0 - -instance IsMember RetrieveUser effs => User.Retriever (Mock effs) where - getById userId = do - Effect.log $ GetUserById userId - return . Just $ Fixture.entity Fixture.user - - getByUsername username = do - Effect.log $ GetUserByUsername username - return . Just $ Fixture.entity Fixture.user - - getByPublicKey pk = do - Effect.log $ GetUserByPublicKey pk - return . Just $ Fixture.entity Fixture.user - - getByHerokuAddOnId id = do - Effect.log $ GetUserByHerokuAddOnId id - pure . Just $ Fixture.entity Fixture.user - - getByEmail email = do - Effect.log $ GetUserByEmail email - pure . Just $ Fixture.entity Fixture.user - -instance - ( IsMember CreateHerokuAddOn effs - , IsMember CreateUser effs - , IsMember UpdateRoute53 effs - ) - => User.Creator (Mock effs) where - create _ _ _ _ = do - Effect.log CreateUser - Effect.log UpdateRoute53 - return . Right $ Database.toSqlKey 0 - - createWithPassword _ _ _ _ = do - Effect.log CreateUser - Effect.log UpdateRoute53 - return $ Right (Database.toSqlKey 0) - - createWithHeroku uuid _ _ _ _ = do - Effect.log CreateUser - Effect.log $ CreateHerokuAddOn uuid - return . Right $ Database.toSqlKey 0 - -instance IsMember ModifyUser effs => User.Modifier (Mock effs) where - updatePassword uID password _ = do - Effect.log $ ModifyUser uID - return $ Right password - - updatePublicKey uID newPK _ = do - Effect.log $ ModifyUser uID - return $ Right newPK - - addExchangeKey uID key _ = do - Effect.log $ ModifyUser uID - return $ Right [key] - - removeExchangeKey uID _ _ = do - Effect.log $ ModifyUser uID - return $ Right [] - - setData uID _ _ = do - Effect.log $ ModifyUser uID - return ok - -instance IsMember DestroyUser effs => User.Destroyer (Mock effs) where - deactivate _ uid = do - Effect.log $ DestroyUser uid - return ok - -instance IsMember RetrieveLoosePin effs => LoosePin.Retriever (Mock effs) where - getByUserId uid = do - Effect.log $ GetLoosePinByUserId uid - - let - userId = Database.toSqlKey 0 - cid = IPFS.CID "Qm12345" - - return . pure . Fixture.entity $ LoosePin userId cid Fixture.agesAgo - - getByCids cids = sequence . snd $ foldr folder (0, []) cids - where - folder cid (counter, acc) = - (counter + 1, action cid counter : acc) - - action :: IPFS.CID -> Int64 -> Mock effs (Entity LoosePin) - action cid rawUserId = do - let userId = Database.toSqlKey rawUserId - Effect.log $ GetLoosePinByCID cid - return . Fixture.entity $ LoosePin userId cid Fixture.agesAgo - -instance IsMember CreateLoosePin effs => LoosePin.Creator (Mock effs) where - create uid cid _ = do - Effect.log $ CreateLoosePin uid cid - return . Just $ Database.toSqlKey 0 - - createMany uid cids _ = do - forM_ cids \cid -> - Effect.log $ CreateLoosePin uid cid - - return cids - -instance IsMember DestroyLoosePin effs => LoosePin.Destroyer (Mock effs) where - destroy userId cid = - Effect.log $ DestroyLoosePin userId cid - - destroyMany userId cidIds = - forM_ cidIds \id -> - Effect.log $ DestroyLoosePinById userId id diff --git a/fission-web-server/package.yaml b/fission-web-server/package.yaml index b4b24c4b2..939a428e5 100644 --- a/fission-web-server/package.yaml +++ b/fission-web-server/package.yaml @@ -210,10 +210,6 @@ tests: source-dirs: - library - test - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N dependencies: - hspec - hspec-core diff --git a/fission-web-server/test/Fission/Test/Web/Server/Auth.hs b/fission-web-server/test/Fission/Test/Web/Server/Auth.hs index 2edf267a5..6bec24bf8 100644 --- a/fission-web-server/test/Fission/Test/Web/Server/Auth.hs +++ b/fission-web-server/test/Fission/Test/Web/Server/Auth.hs @@ -7,19 +7,26 @@ import Servant.Server.Experimental.Auth import Test.Tasty.Hspec import qualified Fission.Internal.Fixture.Key.Ed25519 as Ed25519 +import Fission.Internal.Mock as Mock + +import Fission.Web.Server.Auth.Class +import Fission.Web.Server.Models import Fission.Web.Server.Fixture.Entity as Fixture import Fission.Web.Server.Fixture.User as Fixture +import Fission.Web.Server.Mock.Config import Fission.User.DID.Types import qualified Fission.Web.API.Heroku.Auth.Types as Heroku import Fission.Web.Server.Auth +import Fission.Web.Server.Auth.Token.Basic.Class import Fission.Web.Server.Authorization.Types import qualified Fission.Test.Web.Server.Auth.Token as Token import qualified Fission.Test.Web.Server.Auth.Token.Bearer as Bearer import qualified Fission.Test.Web.Server.Auth.Token.JWT as JWT -import Fission.Test.Web.Server.Prelude as Mock + +import Fission.Test.Web.Server.Prelude import qualified Fission.Test.Web.Server.Auth.Token.UCAN.Resource as Resource import qualified Fission.Test.Web.Server.Auth.Token.UCAN.Resource.Scope as Scope @@ -52,15 +59,22 @@ spec = it "uses the encapsulated function" do herokuResult `shouldBe` Authorized (Heroku.Auth "FAKE HEROKU") +type Effs = + '[ GetAuthVerifier DID + , GetAuthVerifier (Entity User) + , GetAuthVerifier Authorization + , GetBasicAuth Heroku.Auth + ] + setup :: IO (Either ServerError DID, Either ServerError Authorization, BasicAuthResult Heroku.Auth) setup = do Mock.Session - { effectLog = _effectLog :: [OpenUnion '[]] + { effectLog = _effectLog :: [OpenUnion Effs] , result = AuthHandler didVerifier :. AuthHandler userVerifier :. BasicAuthCheck herokuVerifier :. EmptyContext - } <- runMock @'[] defaultConfig mkAuth + } <- runMock defaultConfig mkAuth did <- runHandler $ didVerifier defaultRequest user' <- runHandler $ userVerifier defaultRequest diff --git a/fission-web-server/test/Fission/Test/Web/Server/Auth/Token/JWT/Validation.hs b/fission-web-server/test/Fission/Test/Web/Server/Auth/Token/JWT/Validation.hs index e5470d00a..e031394d5 100644 --- a/fission-web-server/test/Fission/Test/Web/Server/Auth/Token/JWT/Validation.hs +++ b/fission-web-server/test/Fission/Test/Web/Server/Auth/Token/JWT/Validation.hs @@ -1,9 +1,9 @@ module Fission.Test.Web.Server.Auth.Token.JWT.Validation (spec) where -import qualified Fission.Internal.Fixture.Bearer as Fixture -import qualified Fission.Internal.Fixture.Bearer.Nested as Nested.Fixture +-- import qualified Fission.Internal.Fixture.Bearer as Fixture +-- import qualified Fission.Internal.Fixture.Bearer.Nested as Nested.Fixture -import qualified Fission.Web.Auth.Token.JWT.Validation as JWT +-- import qualified Fission.Web.Auth.Token.JWT.Validation as JWT import Fission.Test.Web.Server.Prelude diff --git a/fission-web-server/test/Fission/Test/Web/Server/Auth/Token/UCAN/Resource.hs b/fission-web-server/test/Fission/Test/Web/Server/Auth/Token/UCAN/Resource.hs index a5a892bbd..24fb74239 100644 --- a/fission-web-server/test/Fission/Test/Web/Server/Auth/Token/UCAN/Resource.hs +++ b/fission-web-server/test/Fission/Test/Web/Server/Auth/Token/UCAN/Resource.hs @@ -2,7 +2,6 @@ module Fission.Test.Web.Server.Auth.Token.UCAN.Resource (spec) where import qualified Data.Aeson as JSON -import qualified Fission.Internal.UTF8 as UTF8 import Fission.Web.Auth.Token.UCAN.Resource.Types import Fission.Test.Web.Server.Prelude diff --git a/fission-web-server/test/Fission/Test/Web/Server/Error.hs b/fission-web-server/test/Fission/Test/Web/Server/Error.hs index 27fa2b3de..0941ac582 100644 --- a/fission-web-server/test/Fission/Test/Web/Server/Error.hs +++ b/fission-web-server/test/Fission/Test/Web/Server/Error.hs @@ -1,8 +1,10 @@ module Fission.Test.Web.Server.Error (spec) where import Fission.Error +import Fission.Internal.Mock as Mock +import Fission.Web.Server.Mock.Config -import Fission.Test.Web.Server.Prelude as Mock +import Fission.Test.Web.Server.Prelude spec :: Spec spec = diff --git a/fission-web-server/test/Fission/Test/Web/Server/Prelude.hs b/fission-web-server/test/Fission/Test/Web/Server/Prelude.hs index 4c32f6ff3..9fc4d954b 100644 --- a/fission-web-server/test/Fission/Test/Web/Server/Prelude.hs +++ b/fission-web-server/test/Fission/Test/Web/Server/Prelude.hs @@ -1,6 +1,5 @@ module Fission.Test.Web.Server.Prelude ( module Fission.Prelude - , module Fission.Web.Server.Mock -- , module Test.Tasty , module Test.Tasty.Hspec @@ -26,8 +25,6 @@ import Test.QuickCheck.Instances () import Fission.Prelude hiding (Result (..), log) -import Fission.Web.Server.Mock - -- | Prop test with description itsProp :: (HasCallStack, Testable a) => String -> Int -> a -> SpecWith () itsProp description times prop = diff --git a/fission-web-server/test/Fission/Test/Web/Server/Root.hs b/fission-web-server/test/Fission/Test/Web/Server/Root.hs index 2768c066a..9a443106a 100644 --- a/fission-web-server/test/Fission/Test/Web/Server/Root.hs +++ b/fission-web-server/test/Fission/Test/Web/Server/Root.hs @@ -2,6 +2,7 @@ module Fission.Test.Web.Server.Root (spec) where import Servant +import Fission.Internal.Mock import qualified Fission.Web.API.Types as API import Fission.Test.Web.Server.Prelude @@ -21,7 +22,7 @@ spec = } rootServer :: IO Application -rootServer = return . serve (Proxy @API.Root) $ runMockIO defaultConfig rootHandler +rootServer = return . serve (Proxy @API.Root) $ runMockIO () rootHandler -rootHandler :: Mock '[] NoContent -- i.e. this type enforces that it produces no effects +rootHandler :: Mock '[] () NoContent -- i.e. this type enforces that it produces no effects rootHandler = return NoContent