mirror of
https://github.com/haskell-nix/hnix-store.git
synced 2024-09-11 18:05:56 +03:00
remote: switch controlParser to Serializer Logger
This commit is contained in:
parent
fb02185c29
commit
5c9f7ad70e
@ -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
|
||||
|
@ -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
|
||||
|
@ -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])
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -87,3 +87,4 @@ spec = parallel $ do
|
||||
prop "Field" $ roundtripS field
|
||||
prop "LoggerOpCode" $ roundtripS loggerOpCode
|
||||
prop "Verbosity" $ roundtripS verbosity
|
||||
prop "Logger" $ roundtripS logger
|
||||
|
Loading…
Reference in New Issue
Block a user