remote: deal with logger, tagless

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
         }

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)

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,15 +139,33 @@ 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
+
+  setError :: m ()
+  default setError
+    :: ( MonadTrans t
+       , MonadRemoteStoreR r m'
+       , m ~ t m'
+       )
+    => m ()
+  setError = lift setError
+
+  clearError :: m ()
+  default clearError
+    :: ( MonadTrans t
+       , MonadRemoteStoreR r m'
+       , m ~ t m'
+       )
+    => m ()
+  clearError = lift clearError
 
   gotError :: m Bool
   default gotError
@@ -155,33 +176,6 @@ class ( MonadIO m
     => m Bool
   gotError = lift gotError
 
-  getErrors :: m [Logger]
-  default getErrors
-    :: ( MonadTrans t
-       , MonadRemoteStoreR r m'
-       , m ~ t m'
-       )
-    => m [Logger]
-  getErrors = lift getErrors
-
-  getLogs :: m [Logger]
-  default getLogs
-    :: ( MonadTrans t
-       , MonadRemoteStoreR r m'
-       , m ~ t m'
-       )
-    => m [Logger]
-  getLogs = lift getLogs
-
-  flushLogs :: m ()
-  default flushLogs
-    :: ( MonadTrans t
-       , MonadRemoteStoreR r m'
-       , m ~ t m'
-       )
-    => m ()
-  flushLogs = lift flushLogs
-
   setData :: ByteString -> m ()
   default setData
    :: ( MonadTrans t
@@ -262,17 +256,14 @@ instance ( MonadIO m
   getStoreDir = hasStoreDir <$> RemoteStoreT ask
   getStoreSocket = hasStoreSocket <$> RemoteStoreT ask
 
-  appendLogs x =
+  appendLog 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
+    $ \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

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

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)

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)