diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index 7d327f3b..1c242cf5 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/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 diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index 857cd242..664b3a50 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/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 ()) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs index 6226f29a..87c32ad8 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs +++ b/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) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs index 82db33a7..72aa6d1f 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs +++ b/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 } diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs index 081497c8..8e332648 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs +++ b/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