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 4a607ec6..4cba45e9 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -21,7 +21,6 @@ import Control.Monad.Reader (ask) import Data.Serialize.Put (Put, runPut) import Data.Some (Some(Some)) -import qualified Data.Bool import qualified Data.ByteString import qualified Network.Socket.ByteString @@ -35,7 +34,7 @@ import System.Nix.Store.Remote.Serializer import System.Nix.Store.Remote.Types.Handshake (Handshake(..)) import System.Nix.Store.Remote.Types.Logger (Logger) import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion, ProtoVersion(..), ourProtoVersion) -import System.Nix.Store.Remote.Types.StoreConfig (HasStoreSocket, PreStoreConfig, StoreConfig, preStoreConfigToStoreConfig) +import System.Nix.Store.Remote.Types.StoreConfig (PreStoreConfig, StoreConfig, preStoreConfigToStoreConfig) import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..)) import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..)) import System.Nix.Store.Remote.Types.WorkerOp (WorkerOp) @@ -46,88 +45,58 @@ import System.Nix.StorePath (StorePathName) import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..)) simpleOp - :: ( MonadIO m - , HasStoreDir r - , HasStoreSocket r - , HasProtoVersion r - ) + :: MonadRemoteStore m => WorkerOp - -> RemoteStoreT r m Bool + -> m Bool simpleOp op = simpleOpArgs op $ pure () simpleOpArgs - :: ( MonadIO m - , HasStoreDir r - , HasStoreSocket r - , HasProtoVersion r - ) + :: MonadRemoteStore m => WorkerOp -> Put - -> RemoteStoreT r m Bool + -> m Bool simpleOpArgs op args = do runOpArgs op args - err <- gotError - Data.Bool.bool - (sockGetS $ mapErrorS RemoteStoreError_SerializerGet bool) - (do - -- TODO: don't use show - getErrors >>= throwError . RemoteStoreError_Fixme . show - ) - err + errored <- gotError + if errored + then throwError RemoteStoreError_OperationFailed + else sockGetS $ mapErrorS RemoteStoreError_SerializerGet bool runOp - :: ( MonadIO m - , HasStoreDir r - , HasStoreSocket r - , HasProtoVersion r - ) + :: MonadRemoteStore m => WorkerOp - -> RemoteStoreT r m () + -> m () runOp op = runOpArgs op $ pure () runOpArgs - :: ( MonadIO m - , HasStoreDir r - , HasStoreSocket r - , HasProtoVersion r - ) + :: MonadRemoteStore m => WorkerOp -> Put - -> RemoteStoreT r m () + -> m () runOpArgs op args = runOpArgsIO op (\encode -> encode $ runPut args) runOpArgsIO - :: ( MonadIO m - , HasStoreDir r - , HasStoreSocket r - , HasProtoVersion r - ) + :: MonadRemoteStore m => WorkerOp - -> ((Data.ByteString.ByteString -> RemoteStoreT r m ()) - -> RemoteStoreT r m () + -> ((Data.ByteString.ByteString -> m ()) + -> m () ) - -> RemoteStoreT r m () + -> m () runOpArgsIO op encoder = do sockPutS (mapErrorS RemoteStoreError_SerializerPut enum) op soc <- getStoreSocket encoder (liftIO . Network.Socket.ByteString.sendAll soc) - out <- processOutput - appendLogs out - err <- gotError - when err $ do - -- TODO: don't use show - getErrors >>= throwError . RemoteStoreError_Fixme . show + processOutput doReq - :: forall m r a + :: forall m a . ( MonadIO m - , MonadRemoteStoreR r m - , HasProtoVersion r + , MonadRemoteStore m , StoreReply a ) => StoreRequest a @@ -149,7 +118,9 @@ doReq = \case _ -> pure () - _ <- either (throwError @RemoteStoreError @m) appendLogs . fst <$> runRemoteStoreT cfg processOutput + --either (throwError @RemoteStoreError @m) (\() -> pure ()) . fst + -- <$> runRemoteStoreT cfg processOutput + processOutput --either throwError pure . fst <$> runRemoteStoreT cfg $ eres <- runRemoteStoreT cfg $ sockGetS (mapErrorS RemoteStoreError_SerializerGet (getReply @a)) @@ -268,15 +239,13 @@ runStoreSocket preStoreConfig code = $ mapErrorS RemoteStoreError_SerializerHandshake trustedFlag else pure Nothing - logs <- - mapStoreConfig - (preStoreConfigToStoreConfig minimumCommonVersion) - processOutput + mapStoreConfig + (preStoreConfigToStoreConfig minimumCommonVersion) + processOutput pure Handshake { handshakeNixVersion = daemonNixVersion , handshakeTrust = remoteTrustsUs , handshakeProtoVersion = minimumCommonVersion , handshakeRemoteProtoVersion = daemonVersion - , handshakeLogs = logs } 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 87c32ad8..66e2e717 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs @@ -3,30 +3,22 @@ module System.Nix.Store.Remote.Logger ) where 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) -import System.Nix.Store.Remote.MonadStore (RemoteStoreT, RemoteStoreError(..), clearData, getData, getProtoVersion) +import System.Nix.Store.Remote.MonadStore (MonadRemoteStore, RemoteStoreError(..), appendLog, clearData, getData, getProtoVersion, setError) import System.Nix.Store.Remote.Types.Logger (Logger(..)) -import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion) -import System.Nix.Store.Remote.Types.StoreConfig (HasStoreSocket(..)) +import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion) import qualified Control.Monad import qualified Data.Serialize.Get import qualified Data.Serializer processOutput - :: ( Monad m - , MonadIO m - , HasProtoVersion r - , HasStoreDir r - , HasStoreSocket r - ) - => RemoteStoreT r m [Logger] + :: MonadRemoteStore m + => m () processOutput = do protoVersion <- getProtoVersion sockGet8 >>= go . (decoder protoVersion) @@ -40,28 +32,28 @@ processOutput = do (runSerialT protoVersion $ Data.Serializer.getS logger) go - :: ( Monad m - , MonadIO m - , HasProtoVersion r - , HasStoreDir r - , HasStoreSocket r - ) + :: MonadRemoteStore m => Result (Either LoggerSError Logger) - -> RemoteStoreT r m [Logger] + -> m () go (Done ectrl leftover) = do + let loop = do + protoVersion <- getProtoVersion + sockGet8 >>= go . (decoder protoVersion) Control.Monad.unless (leftover == mempty) $ -- TODO: throwError error $ "Leftovers detected: '" ++ show leftover ++ "'" - protoVersion <- getProtoVersion case ectrl of -- TODO: tie this with throwError and better error type Left e -> error $ show e Right ctrl -> do case ctrl of - e@(Logger_Error _) -> pure [e] - Logger_Last -> pure [Logger_Last] + -- These two terminate the logger loop + e@(Logger_Error _) -> setError >> appendLog e + Logger_Last -> appendLog Logger_Last + + -- Read data from source Logger_Read _n -> do mdata <- getData case mdata of @@ -71,12 +63,21 @@ processOutput = do sockPut $ putByteString part clearData - sockGet8 >>= go . (decoder protoVersion) + loop + + -- Write data to sink + -- used with tunnel sink in ExportPath operation + Logger_Write _out -> do + -- TODO: handle me + loop + + -- Following we just append and loop + -- but listed here explicitely for posterity + x@(Logger_Next _) -> appendLog x >> loop + x@(Logger_StartActivity {}) -> appendLog x >> loop + x@(Logger_StopActivity {}) -> appendLog x >> loop + x@(Logger_Result {}) -> appendLog x >> loop - -- we should probably handle Read here as well - x -> do - next <- sockGet8 >>= go . (decoder protoVersion) - pure $ x : next go (Partial k) = do chunk <- sockGet8 go (k chunk) 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 f2856b0e..5d41e1fb 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs @@ -16,7 +16,7 @@ module System.Nix.Store.Remote.MonadStore import Control.Monad.Except (MonadError) import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Reader (MonadReader, ask) +import Control.Monad.Reader (MonadReader, ask, asks) import Control.Monad.State.Strict (get, modify) import Control.Monad.Trans (MonadTrans, lift) import Control.Monad.Trans.State.Strict (StateT, runStateT, mapStateT) @@ -28,12 +28,13 @@ import Network.Socket (Socket) import System.Nix.Nar (NarSource) import System.Nix.StorePath (HasStoreDir(..), StoreDir) import System.Nix.Store.Remote.Serializer (HandshakeSError, LoggerSError, SError) -import System.Nix.Store.Remote.Types.Logger (Logger, isError) +import System.Nix.Store.Remote.Types.Logger (Logger) import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion) import System.Nix.Store.Remote.Types.StoreConfig (HasStoreSocket(..), StoreConfig) data RemoteStoreState = RemoteStoreState { remoteStoreState_logs :: [Logger] + , remoteStoreState_gotError :: Bool , remoteStoreState_mData :: Maybe ByteString , remoteStoreState_mNarSource :: Maybe (NarSource IO) } @@ -50,6 +51,7 @@ data RemoteStoreError | RemoteStoreError_SerializerPut SError | RemoteStoreError_NoDataProvided | RemoteStoreError_NoNarSourceProvided + | RemoteStoreError_OperationFailed | RemoteStoreError_ProtocolMismatch | RemoteStoreError_RapairNotSupportedByRemoteStore -- "repairing is not supported when building through the Nix daemon" | RemoteStoreError_WorkerMagic2Mismatch @@ -113,6 +115,7 @@ runRemoteStoreT r = where emptyState = RemoteStoreState { remoteStoreState_logs = mempty + , remoteStoreState_gotError = False , remoteStoreState_mData = Nothing , remoteStoreState_mNarSource = Nothing } @@ -136,51 +139,42 @@ class ( MonadIO m ) => MonadRemoteStoreR r m where - appendLogs :: [Logger] -> m () - default appendLogs + appendLog :: Logger -> m () + default appendLog :: ( MonadTrans t , MonadRemoteStoreR r m' , m ~ t m' ) - => [Logger] + => Logger -> m () - appendLogs = lift . appendLogs + appendLog = lift . appendLog - gotError :: m Bool - default gotError - :: ( MonadTrans t - , MonadRemoteStoreR r m' - , m ~ t m' - ) - => m Bool - gotError = lift gotError - - getErrors :: m [Logger] - default getErrors + setError :: m () + default setError :: ( MonadTrans t , MonadRemoteStoreR r m' , m ~ t m' ) - => m [Logger] - getErrors = lift getErrors + => m () + setError = lift setError - getLogs :: m [Logger] - default getLogs + clearError :: m () + default clearError :: ( MonadTrans t , MonadRemoteStoreR r m' , m ~ t m' ) - => m [Logger] - getLogs = lift getLogs + => m () + clearError = lift clearError - flushLogs :: m () - default flushLogs + gotError :: m Bool + default gotError :: ( MonadTrans t , MonadRemoteStoreR r m' , m ~ t m' ) - => m () - flushLogs = lift flushLogs + => m Bool + gotError = lift gotError setData :: ByteString -> m () default setData @@ -262,17 +256,14 @@ instance ( MonadIO m 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 = + appendLog x = RemoteStoreT $ modify - $ \s -> s { remoteStoreState_logs = mempty } - gotError = any isError <$> getLogs - getErrors = filter isError <$> getLogs + $ \s -> s { remoteStoreState_logs = remoteStoreState_logs s ++ [x] } + + setError = RemoteStoreT $ modify $ \s -> s { remoteStoreState_gotError = True } + clearError = RemoteStoreT $ modify $ \s -> s { remoteStoreState_gotError = False } + gotError = remoteStoreState_gotError <$> RemoteStoreT get getData = remoteStoreState_mData <$> RemoteStoreT get setData x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mData = pure x } @@ -286,8 +277,8 @@ instance ( MonadIO m -- | Ask for a @StoreDir@ getProtoVersion - :: ( Monad m + :: ( MonadRemoteStoreR r m , HasProtoVersion r ) - => RemoteStoreT r m ProtoVersion -getProtoVersion = hasProtoVersion <$> RemoteStoreT ask + => m ProtoVersion +getProtoVersion = asks hasProtoVersion diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs index 3e00bebc..609ff7f0 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs @@ -86,8 +86,6 @@ processConnection workerHelper preStoreConfig = do , handshakeProtoVersion = ourProtoVersion -- TODO: doesn't make sense for server , handshakeRemoteProtoVersion = ourProtoVersion - -- TODO: try this - , handshakeLogs = mempty } ~() <- void $ runRemoteStoreT preStoreConfig $ do 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 8e332648..d9cb4943 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs @@ -8,8 +8,8 @@ import Data.HashSet (HashSet) 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) +import System.Nix.StorePath (StorePath) +import System.Nix.Store.Remote.MonadStore (MonadRemoteStore, MonadRemoteStoreR, 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(..)) @@ -34,22 +34,20 @@ genericIncremental getsome parser = do go (Fail msg _leftover) = error msg sockGet8 - :: ( Monad m - , MonadIO m + :: ( MonadRemoteStoreR r m , HasStoreSocket r ) - => RemoteStoreT r m ByteString + => m ByteString sockGet8 = do soc <- asks hasStoreSocket liftIO $ recv soc 8 sockPut - :: ( Monad m - , MonadIO m + :: ( MonadRemoteStoreR r m , HasStoreSocket r ) => Put - -> RemoteStoreT r m () + -> m () sockPut p = do soc <- asks hasStoreSocket liftIO $ sendAll soc $ runPut p @@ -99,63 +97,40 @@ sockGetS s = do -- * Obsolete getSocketIncremental - :: ( Monad m - , MonadIO m - , HasStoreSocket r - ) + :: MonadRemoteStore m => Get a - -> RemoteStoreT r m a + -> m a getSocketIncremental = genericIncremental sockGet8 sockGet - :: ( Monad m - , MonadIO m - , HasStoreSocket r - ) + :: MonadRemoteStore m => Get a - -> RemoteStoreT r m a + -> m a sockGet = getSocketIncremental sockGetInt - :: ( Monad m - , MonadIO m - , HasStoreSocket r - , Integral a - ) - => RemoteStoreT r m a + :: (Integral a, MonadRemoteStore m) + => m a sockGetInt = getSocketIncremental getInt sockGetBool - :: ( Monad m - , MonadIO m - , HasStoreSocket r - ) - => RemoteStoreT r m Bool + :: MonadRemoteStore m + => m Bool sockGetBool = (== (1 :: Int)) <$> sockGetInt sockGetStr - :: ( Monad m - , MonadIO m - , HasStoreSocket r - ) - => RemoteStoreT r m ByteString + :: MonadRemoteStore m + => m ByteString sockGetStr = getSocketIncremental getByteString sockGetStrings - :: ( Monad m - , MonadIO m - , HasStoreSocket r - ) - => RemoteStoreT r m [ByteString] + :: MonadRemoteStore m + => m [ByteString] sockGetStrings = getSocketIncremental getByteStrings sockGetPath - :: ( Monad m - , MonadIO m - , HasStoreDir r - , HasStoreSocket r - ) - => RemoteStoreT r m StorePath + :: MonadRemoteStore m + => m StorePath sockGetPath = do sd <- getStoreDir pth <- getSocketIncremental (getPath sd) @@ -165,12 +140,8 @@ sockGetPath = do pth sockGetPathMay - :: ( Monad m - , MonadIO m - , HasStoreDir r - , HasStoreSocket r - ) - => RemoteStoreT r m (Maybe StorePath) + :: MonadRemoteStore m + => m (Maybe StorePath) sockGetPathMay = do sd <- getStoreDir pth <- getSocketIncremental (getPath sd) @@ -181,12 +152,8 @@ sockGetPathMay = do pth sockGetPaths - :: ( Monad m - , MonadIO m - , HasStoreDir r - , HasStoreSocket r - ) - => RemoteStoreT r m (HashSet StorePath) + :: MonadRemoteStore m + => m (HashSet StorePath) sockGetPaths = do sd <- getStoreDir getSocketIncremental (getPathsOrFail sd) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/Handshake.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Handshake.hs index 644394c0..81f62cd9 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/Handshake.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Handshake.hs @@ -4,7 +4,6 @@ module System.Nix.Store.Remote.Types.Handshake import Data.Text (Text) import GHC.Generics (Generic) -import System.Nix.Store.Remote.Types.Logger (Logger) import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion) import System.Nix.Store.Remote.Types.TrustedFlag (TrustedFlag) @@ -14,6 +13,5 @@ data Handshake = Handshake , handshakeTrust :: Maybe TrustedFlag -- ^ Whether remote side trusts us , handshakeProtoVersion :: ProtoVersion -- ^ Minimum protocol supported by both sides , handshakeRemoteProtoVersion :: ProtoVersion -- ^ Protocol supported by remote side - , handshakeLogs :: [Logger] -- ^ Logs produced right after greeting exchange } deriving (Eq, Generic, Ord, Show)