Skip to content

Commit

Permalink
remote: deal with logger, tagless
Browse files Browse the repository at this point in the history
  • Loading branch information
sorki committed Dec 3, 2023
1 parent ebb4161 commit 1eadba1
Show file tree
Hide file tree
Showing 6 changed files with 108 additions and 184 deletions.
83 changes: 26 additions & 57 deletions hnix-store-remote/src/System/Nix/Store/Remote/Client.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand All @@ -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)
Expand All @@ -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
Expand All @@ -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))
Expand Down Expand Up @@ -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
}
55 changes: 28 additions & 27 deletions hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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
Expand All @@ -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)
Expand Down
69 changes: 30 additions & 39 deletions hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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)
}
Expand All @@ -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
Expand Down Expand Up @@ -113,6 +115,7 @@ runRemoteStoreT r =
where
emptyState = RemoteStoreState
{ remoteStoreState_logs = mempty
, remoteStoreState_gotError = False
, remoteStoreState_mData = Nothing
, remoteStoreState_mNarSource = Nothing
}
Expand All @@ -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
Expand Down Expand Up @@ -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 }
Expand All @@ -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

0 comments on commit 1eadba1

Please sign in to comment.