mirror of
https://github.com/haskell-nix/hnix-store.git
synced 2024-09-11 18:05:56 +03:00
remote: MonadRemoteStore typeclass
Related to #72 Co-Authored-By: Guillaume Maudoux <layus.on@gmail.com>
This commit is contained in:
parent
bc98de1bf3
commit
c0a17f25a0
@ -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
|
||||
|
@ -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 ())
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
class ( Monad m
|
||||
, MonadError RemoteStoreError m
|
||||
)
|
||||
=> MonadRemoteStore m where
|
||||
|
||||
-- | Ask for a @StoreDir@
|
||||
getStoreSocket
|
||||
:: ( Monad m
|
||||
, HasStoreSocket r
|
||||
)
|
||||
=> RemoteStoreT r m Socket
|
||||
getStoreSocket = hasStoreSocket <$> RemoteStoreT ask
|
||||
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 }
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user