remote: switch controlParser to Serializer Logger

hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs

@@ -26,5 +26,8 @@ deriving via GenericArbitrary Field
 deriving via GenericArbitrary LoggerOpCode
   instance Arbitrary LoggerOpCode
 
+deriving via GenericArbitrary Logger
+  instance Arbitrary Logger
+
 deriving via GenericArbitrary Verbosity
   instance Arbitrary Verbosity

hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs

@@ -1,83 +1,54 @@
 module System.Nix.Store.Remote.Logger
-  ( Logger(..)
-  , Field(..)
-  , processOutput
+  ( processOutput
   ) where
 
 import Control.Monad.Except (throwError)
-import Data.Serialize (Get, Result(..))
-import System.Nix.Store.Remote.Serialize ()
-import System.Nix.Store.Remote.Serialize.Prim
-import System.Nix.Store.Remote.Socket
-import System.Nix.Store.Remote.MonadStore
-import System.Nix.Store.Remote.Types
+import Data.ByteString (ByteString)
+import Data.Serialize (Result(..))
+import System.Nix.Store.Remote.Serialize.Prim (putByteString)
+import System.Nix.Store.Remote.Serializer (logger, runSerialT)
+import System.Nix.Store.Remote.Socket (sockGet8, sockPut)
+import System.Nix.Store.Remote.MonadStore (MonadStore, clearData)
+import System.Nix.Store.Remote.Types (Logger(..))
 
-import qualified Control.Monad
 import qualified Control.Monad.State.Strict
-import qualified Data.Serialize
 import qualified Data.Serialize.Get
-
-controlParser :: Get Logger
-controlParser = do
-  ctrl <- Data.Serialize.get
-  case (ctrl :: LoggerOpCode) of
-    LoggerOpCode_Next ->
-      Next <$> getByteString
-    LoggerOpCode_Read ->
-      Read <$> getInt
-    LoggerOpCode_Write ->
-      Write <$> getByteString
-    LoggerOpCode_Last ->
-      pure Last
-    LoggerOpCode_Error ->
-      flip Error <$> getByteString
-                 <*> getInt
-    LoggerOpCode_StartActivity ->
-      StartActivity <$> (ActivityID <$> getInt)
-                    <*> Data.Serialize.get
-                    <*> getInt
-                    <*> getByteString
-                    <*> getFields
-                    <*> (ActivityID <$> getInt)
-    LoggerOpCode_StopActivity ->
-      StopActivity  <$> (ActivityID <$> getInt)
-    LoggerOpCode_Result ->
-      Result <$> (ActivityID <$> getInt)
-             <*> getInt
-             <*> getFields
+import qualified Data.Serializer
 
 processOutput :: MonadStore [Logger]
 processOutput = do
  sockGet8 >>= go . decoder
  where
-  decoder = Data.Serialize.Get.runGetPartial controlParser
-  go :: Result Logger -> MonadStore [Logger]
-  go (Done ctrl _leftover) = do
-    case ctrl of
-      e@(Error _ _) -> pure [e]
-      Last          -> pure [Last]
-      Read _n       -> do
-        (mdata, _) <- Control.Monad.State.Strict.get
-        case mdata of
-          Nothing   -> throwError "No data to read provided"
-          Just part -> do
-            -- XXX: we should check/assert part size against n of (Read n)
-            sockPut $ putByteString part
-            clearData
+  decoder :: ByteString -> Result (Either () Logger)
+  decoder =
+    Data.Serialize.Get.runGetPartial
+      (runSerialT () $ Data.Serializer.getS logger)
+  go :: Result (Either () Logger) -> MonadStore [Logger]
+  go (Done ectrl _leftover) = do
+    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]
+          Logger_Read _n -> do
+            (mdata, _) <- Control.Monad.State.Strict.get
+            case mdata of
+              Nothing   -> throwError "No data to read provided"
+              Just part -> do
+                -- XXX: we should check/assert part size against n of (Read n)
+                sockPut $ putByteString part
+                clearData
 
-        sockGet8 >>= go . decoder
+            sockGet8 >>= go . decoder
 
-      -- we should probably handle Read here as well
-      x -> do
-        next <- sockGet8 >>= go . decoder
-        pure $ x : next
+          -- we should probably handle Read here as well
+          x -> do
+            next <- sockGet8 >>= go . decoder
+            pure $ x : next
   go (Partial k) = do
     chunk <- sockGet8
     go (k chunk)
 
   go (Fail msg _leftover) = error msg
-
-getFields :: Get [Field]
-getFields = do
-  cnt <- getInt
-  Control.Monad.replicateM cnt Data.Serialize.get

hnix-store-remote/src/System/Nix/Store/Remote/Protocol.hs

@@ -69,7 +69,7 @@ simpleOpArgs op args = do
     sockGetBool
     (do
       -- TODO: errorExitStatus, head
-      Error{..} <- head <$> getError
+      Logger_Error{..} <- head <$> getError
       throwError $ Data.ByteString.Char8.unpack errorMessage
     )
     err
@@ -99,7 +99,7 @@ runOpArgsIO op encoder = do
   err <- gotError
   Control.Monad.when err $ do
     -- TODO: errorExitStatus, head
-    Error{..} <- head <$> getError
+    Logger_Error{..} <- head <$> getError
     throwError $ Data.ByteString.Char8.unpack errorMessage
 
 runStore :: MonadStore a -> IO (Either String a, [Logger])

hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs

@@ -10,6 +10,7 @@ module System.Nix.Store.Remote.Serializer
   -- * NixSerializer
     NixSerializer
   -- ** Runners
+  , runSerialT
   , runG
   , runP
   -- * Primitives
@@ -33,6 +34,7 @@ module System.Nix.Store.Remote.Serializer
   , activityResult
   , field
   , loggerOpCode
+  , logger
   , verbosity
   ) where
 
@@ -224,5 +226,70 @@ field = liftSerialize
 loggerOpCode :: NixSerializer r e LoggerOpCode
 loggerOpCode = liftSerialize
 
+logger :: NixSerializer r e Logger
+logger = Serializer
+  { getS = getS loggerOpCode >>= \case
+      LoggerOpCode_Next ->
+        Logger_Next <$> getS byteString
+      LoggerOpCode_Read ->
+        Logger_Read <$> getS int
+      LoggerOpCode_Write ->
+        Logger_Write <$> getS byteString
+      LoggerOpCode_Last ->
+        pure Logger_Last
+      LoggerOpCode_Error -> do
+        errorMessage <- getS byteString
+        errorExitStatus <- getS int
+        pure Logger_Error{..}
+      LoggerOpCode_StartActivity -> do
+        startActivityID <- getS activityID
+        startActivityVerbosity <- getS verbosity
+        startActivityType <- getS maybeActivity
+        startActivityString <- getS byteString
+        startActivityFields <- getS (list field)
+        startActivityParentID <- getS activityID
+        pure Logger_StartActivity{..}
+      LoggerOpCode_StopActivity -> do
+        stopActivityID <- getS activityID
+        pure Logger_StopActivity{..}
+      LoggerOpCode_Result -> do
+        resultActivityID <- getS activityID
+        resultType <- getS activityResult
+        resultFields <- getS (list field)
+        pure Logger_Result {..}
+    , putS = \case
+        Logger_Next s -> do
+          putS loggerOpCode LoggerOpCode_Next
+          putS byteString s
+        Logger_Read i -> do
+          putS loggerOpCode LoggerOpCode_Read
+          putS int i
+        Logger_Write s -> do
+          putS loggerOpCode LoggerOpCode_Write
+          putS byteString s
+        Logger_Last ->
+          putS loggerOpCode LoggerOpCode_Last
+        Logger_Error{..} -> do
+          putS loggerOpCode LoggerOpCode_Error
+          putS byteString errorMessage
+          putS int errorExitStatus
+        Logger_StartActivity{..} -> do
+          putS loggerOpCode LoggerOpCode_StartActivity
+          putS activityID startActivityID
+          putS verbosity startActivityVerbosity
+          putS maybeActivity startActivityType
+          putS byteString startActivityString
+          putS (list field) startActivityFields
+          putS activityID startActivityParentID
+        Logger_StopActivity{..} -> do
+          putS loggerOpCode LoggerOpCode_StopActivity
+          putS activityID stopActivityID
+        Logger_Result{..} -> do
+          putS loggerOpCode LoggerOpCode_Result
+          putS activityID resultActivityID
+          putS activityResult resultType
+          putS (list field) resultFields
+  }
+
 verbosity :: NixSerializer r e Verbosity
 verbosity = liftSerialize

hnix-store-remote/src/System/Nix/Store/Remote/Types/Logger.hs

@@ -5,19 +5,13 @@ module System.Nix.Store.Remote.Types.Logger
   , loggerOpCodeToInt
   , intToLoggerOpCode
   , isError
-  -- to be nuked/newtyped
-  , ActivityType
-  , ResultType
   ) where
 
 import Data.ByteString (ByteString)
 import GHC.Generics
-import System.Nix.Store.Remote.Types.Activity (ActivityID)
+import System.Nix.Store.Remote.Types.Activity (Activity, ActivityID, ActivityResult)
 import System.Nix.Store.Remote.Types.Verbosity (Verbosity)
 
-type ActivityType = Int
-type ResultType = Int
-
 data Field
   = Field_LogStr ByteString
   | Field_LogInt Int
@@ -58,32 +52,32 @@ intToLoggerOpCode = \case
   x -> Left $ "Invalid LoggerOpCode: " ++ show x
 
 data Logger
-  = Next ByteString
-  | Read Int         -- data needed from source
-  | Write ByteString -- data for sink
-  | Last
-  | Error
+  = Logger_Next ByteString
+  | Logger_Read Int         -- data needed from source
+  | Logger_Write ByteString -- data for sink
+  | Logger_Last
+  | Logger_Error
       { errorExitStatus :: Int
       , errorMessage :: ByteString
       }
-  | StartActivity
+  | Logger_StartActivity
       { startActivityID :: ActivityID
       , startActivityVerbosity :: Verbosity
-      , startActivityType :: ActivityType
+      , startActivityType :: Maybe Activity
       , startActivityString :: ByteString
       , startActivityFields :: [Field]
       , startActivityParentID :: ActivityID
       }
-  | StopActivity
+  | Logger_StopActivity
       { stopActivityID :: ActivityID
       }
-  | Result
+  | Logger_Result
       { resultActivityID :: ActivityID
-      , resultType :: ResultType
+      , resultType :: ActivityResult
       , resultFields :: [Field]
       }
   deriving (Eq, Generic, Ord, Show)
 
 isError :: Logger -> Bool
-isError (Error _ _) = True
-isError _           = False
+isError Logger_Error {} = True
+isError _ = False

hnix-store-remote/tests/NixSerializerSpec.hs

@@ -87,3 +87,4 @@ spec = parallel $ do
       prop "Field" $ roundtripS field
       prop "LoggerOpCode" $ roundtripS loggerOpCode
       prop "Verbosity" $ roundtripS verbosity
+      prop "Logger" $ roundtripS logger