remote: deal with logger, tagless

haskell-nix · Dec 3, 2023 · 1eadba1 · 1eadba1
1 parent ebb4161
commit 1eadba1
Show file tree

Hide file tree

Showing 6 changed files with 108 additions and 184 deletions.
diff --git 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
@@ -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
@@ -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