Generalize Mock to work with CLI (#554)

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)

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

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)
+

fission-web-server/library/Fission/Web/Server/Mock/Session/Types.hs → 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
 

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"

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

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

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