remote: MonadRemoteStore typeclass

Related to #72

Co-Authored-By: Guillaume Maudoux <[email protected]>

hnix-store-remote/hnix-store-remote.cabal

@@ -20,6 +20,7 @@ common commons
   ghc-options:  -Wall
   default-extensions:
       DataKinds
+    , DefaultSignatures
     , DeriveGeneric
     , DeriveDataTypeable
     , DeriveFunctor
@@ -34,6 +35,7 @@ common commons
     , ScopedTypeVariables
     , StandaloneDeriving
     , TypeApplications
+    , TypeOperators
     , TypeSynonymInstances
     , InstanceSigs
     , KindSignatures

hnix-store-remote/src/System/Nix/Store/Remote/Client.hs

@@ -20,6 +20,7 @@ import qualified Data.Bool
 import qualified Data.ByteString
 import qualified Network.Socket.ByteString
 
+import System.Nix.StorePath (HasStoreDir(..))
 import System.Nix.Store.Remote.Logger (processOutput)
 import System.Nix.Store.Remote.MonadStore
 import System.Nix.Store.Remote.Socket (sockPutS, sockGetS)
@@ -32,20 +33,20 @@ import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..))
 import System.Nix.Store.Remote.Types.WorkerOp (WorkerOp)
 
 simpleOp
-  :: ( Monad m
-     , MonadIO m
-     , HasProtoVersion r
+  :: ( MonadIO m
+     , HasStoreDir r
      , HasStoreSocket r
+     , HasProtoVersion r
      )
   => WorkerOp
   -> RemoteStoreT r m Bool
 simpleOp op = simpleOpArgs op $ pure ()
 
 simpleOpArgs
-  :: ( Monad m
-     , MonadIO m
-     , HasProtoVersion r
+  :: ( MonadIO m
+     , HasStoreDir r
      , HasStoreSocket r
+     , HasProtoVersion r
      )
   => WorkerOp
   -> Put
@@ -62,20 +63,20 @@ simpleOpArgs op args = do
     err
 
 runOp
-  :: ( Monad m
-     , MonadIO m
-     , HasProtoVersion r
+  :: ( MonadIO m
+     , HasStoreDir r
      , HasStoreSocket r
+     , HasProtoVersion r
      )
   => WorkerOp
   -> RemoteStoreT r m ()
 runOp op = runOpArgs op $ pure ()
 
 runOpArgs
-  :: ( Monad m
-     , MonadIO m
-     , HasProtoVersion r
+  :: ( MonadIO m
+     , HasStoreDir r
      , HasStoreSocket r
+     , HasProtoVersion r
      )
   => WorkerOp
   -> Put
@@ -86,10 +87,10 @@ runOpArgs op args =
     (\encode -> encode $ runPut args)
 
 runOpArgsIO
-  :: ( Monad m
-     , MonadIO m
-     , HasProtoVersion r
+  :: ( MonadIO m
+     , HasStoreDir r
      , HasStoreSocket r
+     , HasProtoVersion r
      )
   => WorkerOp
   -> ((Data.ByteString.ByteString -> RemoteStoreT r m ())

hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs

@@ -6,6 +6,7 @@ import Control.Monad.Except (throwError)
 import Control.Monad.IO.Class (MonadIO)
 import Data.ByteString (ByteString)
 import Data.Serialize (Result(..))
+import System.Nix.StorePath (HasStoreDir(..))
 import System.Nix.Store.Remote.Serialize.Prim (putByteString)
 import System.Nix.Store.Remote.Serializer (LoggerSError, logger, runSerialT)
 import System.Nix.Store.Remote.Socket (sockGet8, sockPut)
@@ -22,6 +23,7 @@ processOutput
   :: ( Monad m
      , MonadIO m
      , HasProtoVersion r
+     , HasStoreDir r
      , HasStoreSocket r
      )
   => RemoteStoreT r m [Logger]
@@ -41,6 +43,7 @@ processOutput = do
     :: ( Monad m
        , MonadIO m
        , HasProtoVersion r
+       , HasStoreDir r
        , HasStoreSocket r
        )
     => Result (Either LoggerSError Logger)

hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs

@@ -7,20 +7,8 @@ module System.Nix.Store.Remote.MonadStore
   , RemoteStoreT
   , runRemoteStoreT
   , mapStoreConfig
-  -- * Reader helpers
-  , getStoreDir
-  , getStoreSocket
+  , MonadRemoteStore(..)
   , getProtoVersion
-  -- * Logs
-  , appendLogs
-  , getLogs
-  , flushLogs
-  , gotError
-  , getErrors
-  -- * Data required from client
-  , getData
-  , setData
-  , clearData
   ) where
 
 import Control.Monad.Except (MonadError)
@@ -119,21 +107,131 @@ mapStoreConfig f =
     ) f
   . _unRemoteStoreT
 
--- | Ask for a @StoreDir@
-getStoreDir
-  :: ( Monad m
-     , HasStoreDir r
-     )
-  => RemoteStoreT r m StoreDir
-getStoreDir = hasStoreDir <$> RemoteStoreT ask
-
--- | Ask for a @StoreDir@
-getStoreSocket
-  :: ( Monad m
-     , HasStoreSocket r
-     )
-  => RemoteStoreT r m Socket
-getStoreSocket = hasStoreSocket <$> RemoteStoreT ask
+class ( Monad m
+      , MonadError RemoteStoreError m
+      )
+      => MonadRemoteStore m where
+
+  appendLogs :: [Logger] -> m ()
+  default appendLogs
+    :: ( MonadTrans t
+       , MonadRemoteStore m'
+       , m ~ t m'
+       )
+    => [Logger]
+    -> m ()
+  appendLogs = lift . appendLogs
+
+  gotError :: m Bool
+  default gotError
+    :: ( MonadTrans t
+       , MonadRemoteStore m'
+       , m ~ t m'
+       )
+    => m Bool
+  gotError = lift gotError
+
+  getErrors :: m [Logger]
+  default getErrors
+    :: ( MonadTrans t
+       , MonadRemoteStore m'
+       , m ~ t m'
+       )
+    => m [Logger]
+  getErrors = lift getErrors
+
+  getLogs :: m [Logger]
+  default getLogs
+    :: ( MonadTrans t
+       , MonadRemoteStore m'
+       , m ~ t m'
+       )
+    => m [Logger]
+  getLogs = lift getLogs
+
+  flushLogs :: m ()
+  default flushLogs
+    :: ( MonadTrans t
+       , MonadRemoteStore m'
+       , m ~ t m'
+       )
+    => m ()
+  flushLogs = lift flushLogs
+
+  setData :: ByteString -> m ()
+  default setData
+   :: ( MonadTrans t
+      , MonadRemoteStore m'
+      , m ~ t m'
+      )
+   => ByteString
+   -> m ()
+  setData = lift . setData
+
+  getData :: m (Maybe ByteString)
+  default getData
+    :: ( MonadTrans t
+       , MonadRemoteStore m'
+       , m ~ t m'
+       )
+    => m (Maybe ByteString)
+  getData = lift getData
+
+  clearData :: m ()
+  default clearData
+    :: ( MonadTrans t
+       , MonadRemoteStore m'
+       , m ~ t m'
+       )
+    => m ()
+  clearData = lift clearData
+
+  getStoreDir :: m StoreDir
+  default getStoreDir
+    :: ( MonadTrans t
+       , MonadRemoteStore m'
+       , m ~ t m'
+       )
+    => m StoreDir
+  getStoreDir = lift getStoreDir
+
+  getStoreSocket :: m Socket
+  default getStoreSocket
+    :: ( MonadTrans t
+       , MonadRemoteStore m'
+       , m ~ t m'
+       )
+    => m Socket
+  getStoreSocket = lift getStoreSocket
+
+instance MonadRemoteStore m => MonadRemoteStore (StateT s m)
+instance MonadRemoteStore m => MonadRemoteStore (ReaderT r m)
+instance MonadRemoteStore m => MonadRemoteStore (ExceptT RemoteStoreError m)
+
+instance ( Monad m
+         , HasStoreDir r
+         , HasStoreSocket r
+         )
+         => MonadRemoteStore (RemoteStoreT r m) where
+
+  getStoreDir = hasStoreDir <$> RemoteStoreT ask
+  getStoreSocket = hasStoreSocket <$> RemoteStoreT ask
+
+  appendLogs x =
+    RemoteStoreT
+    $ modify
+    $ \s -> s { remoteStoreState_logs = remoteStoreState_logs s <> x }
+  getLogs = remoteStoreState_logs <$> RemoteStoreT get
+  flushLogs =
+    RemoteStoreT
+    $ modify
+    $ \s -> s { remoteStoreState_logs = mempty }
+  gotError = any isError <$> getLogs
+  getErrors = filter isError <$> getLogs
+
+  getData = remoteStoreState_mData <$> RemoteStoreT get
+  setData x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mData = pure x }
+  clearData = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mData = Nothing }
 
 -- | Ask for a @StoreDir@
 getProtoVersion
@@ -142,33 +240,3 @@ getProtoVersion
      )
   => RemoteStoreT r m ProtoVersion
 getProtoVersion = hasProtoVersion <$> RemoteStoreT ask
-
--- * Logs
-
-gotError :: Monad m => RemoteStoreT r m Bool
-gotError = any isError <$> getLogs
-
-getErrors :: Monad m => RemoteStoreT r m [Logger]
-getErrors = filter isError <$> getLogs
-
-appendLogs :: Monad m => [Logger] -> RemoteStoreT r m ()
-appendLogs x = RemoteStoreT
-  $ modify
-  $ \s -> s { remoteStoreState_logs = remoteStoreState_logs s <> x }
-
-getLogs :: Monad m => RemoteStoreT r m [Logger]
-getLogs = remoteStoreState_logs <$> RemoteStoreT get
-
-flushLogs :: Monad m => RemoteStoreT r m ()
-flushLogs = RemoteStoreT $ modify $ \s -> s { remoteStoreState_logs = mempty }
-
--- * Data required from client
-
-getData :: Monad m => RemoteStoreT r m (Maybe ByteString)
-getData = remoteStoreState_mData <$> RemoteStoreT get
-
-setData :: Monad m => ByteString -> RemoteStoreT r m ()
-setData x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mData = pure x }
-
-clearData :: Monad m => RemoteStoreT r m ()
-clearData = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mData = Nothing }

hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs

@@ -9,7 +9,7 @@ import Data.Serialize.Get (Get, Result(..))
 import Data.Serialize.Put (Put, runPut)
 import Network.Socket.ByteString (recv, sendAll)
 import System.Nix.StorePath (HasStoreDir, StorePath)
-import System.Nix.Store.Remote.MonadStore (RemoteStoreT, RemoteStoreError(..), getStoreDir, getStoreSocket)
+import System.Nix.Store.Remote.MonadStore (RemoteStoreT, RemoteStoreError(..), getStoreDir)
 import System.Nix.Store.Remote.Serializer (NixSerializer, runP, runSerialT)
 import System.Nix.Store.Remote.Serialize.Prim (getInt, getByteString, getByteStrings, getPath, getPathsOrFail)
 import System.Nix.Store.Remote.Types (HasStoreSocket(..))
@@ -40,7 +40,7 @@ sockGet8
      )
   => RemoteStoreT r m ByteString
 sockGet8 = do
-  soc <- getStoreSocket
+  soc <- asks hasStoreSocket
   liftIO $ recv soc 8
 
 sockPut
@@ -51,7 +51,7 @@ sockPut
   => Put
   -> RemoteStoreT r m ()
 sockPut p = do
-  soc <- getStoreSocket
+  soc <- asks hasStoreSocket
   liftIO $ sendAll soc $ runPut p
 
 sockPutS