From 247b534fc770524f83f848171e7623a8bfaee226 Mon Sep 17 00:00:00 2001 From: Travis Whitaker Date: Sun, 5 Apr 2020 14:33:34 -0700 Subject: [PATCH] hnix-store-remote: Remove ExceptT, use DList to accumulate log. --- .gitignore | 1 + hnix-store-remote/hnix-store-remote.cabal | 1 + .../src/System/Nix/Store/Remote/Logger.hs | 24 ++++++---- .../src/System/Nix/Store/Remote/Protocol.hs | 46 +++++++++---------- .../src/System/Nix/Store/Remote/Types.hs | 37 ++++++++------- .../src/System/Nix/Store/Remote/Util.hs | 3 -- 6 files changed, 57 insertions(+), 55 deletions(-) diff --git a/.gitignore b/.gitignore index 97d19a72..6ee3cadb 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ dist dist-newstyle .ghc.environment* +cabal.project.local diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index 780e39b7..8540bdad 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -26,6 +26,7 @@ library , binary , bytestring , containers + , dlist , text , unix , network diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs index 36648453..d01465e5 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs @@ -4,9 +4,16 @@ module System.Nix.Store.Remote.Logger ( , processOutput) where +import Control.Exception + import Control.Monad.Reader (ask, liftIO) +import Control.Monad.State (modify) import Data.Binary.Get +import qualified Data.ByteString.Lazy.Char8 as LBS + +import Data.DList (snoc) + import Network.Socket.ByteString (recv) import System.Nix.Store.Remote.Types @@ -26,25 +33,24 @@ controlParser = do 0x52534c54 -> Result <$> getInt <*> getInt <*> getFields x -> fail $ "Invalid control message received:" ++ show x -processOutput :: MonadStore [Logger] +processOutput :: MonadStore () processOutput = go decoder where decoder = runGetIncremental controlParser - go :: Decoder Logger -> MonadStore [Logger] + go :: Decoder Logger -> MonadStore () go (Done _leftover _consumed ctrl) = do case ctrl of - e@(Error _ _) -> return [e] - Last -> return [Last] + Error i e -> liftIO (throwIO (ProtocolError i (LBS.unpack e))) + Last -> modify (`snoc` Last) -- we should probably handle Read here as well x -> do - next <- go decoder - return $ x:next + modify (`snoc` x) + go decoder go (Partial k) = do soc <- ask chunk <- liftIO (Just <$> recv soc 8) go (k chunk) - - go (Fail _leftover _consumed msg) = do - error msg + go (Fail _leftover _consumed msg) = + liftIO (throwIO (ParseError msg)) getFields :: Get [Field] getFields = do diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Protocol.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Protocol.hs index e0e724cd..c9ba58c6 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Protocol.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Protocol.hs @@ -4,6 +4,7 @@ module System.Nix.Store.Remote.Protocol ( , simpleOpArgs , runOp , runOpArgs + , runOpArgsDebug , runStore) where import Control.Exception (bracket) @@ -13,12 +14,15 @@ import Control.Monad.State import Data.Binary.Get import Data.Binary.Put -import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as LBS -import Network.Socket hiding (send, sendTo, recv, recvFrom) +import Data.DList (toList) + +import Network.Socket import Network.Socket.ByteString (recv) +import System.IO + import System.Nix.Store.Remote.Logger import System.Nix.Store.Remote.Types import System.Nix.Store.Remote.Util @@ -114,13 +118,7 @@ simpleOp op = do simpleOpArgs :: WorkerOp -> Put -> MonadStore Bool simpleOpArgs op args = do runOpArgs op args - err <- gotError - case err of - True -> do - Error _num msg <- head <$> getError - throwError $ BSC.unpack $ LBS.toStrict msg - False -> do - sockGetBool + sockGetBool runOp :: WorkerOp -> MonadStore () runOp op = runOpArgs op $ return () @@ -128,24 +126,20 @@ runOp op = runOpArgs op $ return () runOpArgs :: WorkerOp -> Put -> MonadStore () runOpArgs op args = do - -- Temporary hack for printing the messages destined for nix-daemon socket - when False $ - liftIO $ LBS.writeFile "mytestfile2" $ runPut $ do - putInt $ opNum op - args - sockPut $ do putInt $ opNum op args - out <- processOutput - modify (++out) - err <- gotError - when err $ do - Error _num msg <- head <$> getError - throwError $ BSC.unpack $ LBS.toStrict msg + processOutput + -- modify (++out) + +-- | Writes all sent messages to stderr. +runOpArgsDebug :: WorkerOp -> Put -> MonadStore () +runOpArgsDebug op args = do + liftIO $ LBS.hPutStr stderr (runPut (putInt (opNum op) *> args)) + runOpArgs op args -runStore :: MonadStore a -> IO (Either String a, [Logger]) +runStore :: MonadStore a -> IO (a, [Logger]) runStore code = do bracket (open sockPath) close run where @@ -157,6 +151,7 @@ runStore code = do sockPut $ putInt workerMagic1 soc <- ask vermagic <- liftIO $ recv soc 16 + -- todo: better checks here let (magic2, daemonProtoVersion) = flip runGet (LBS.fromStrict vermagic) $ (,) <$> getInt <*> getInt unless (magic2 == workerMagic2) $ error "Worker magic 2 mismatch" @@ -166,5 +161,8 @@ runStore code = do processOutput - run sock = - flip runReaderT sock $ flip runStateT [] $ runExceptT (greet >> code) + run sock = do + (a, dl) <- flip runReaderT sock $ + flip runStateT mempty $ + (greet >> code) + pure (a, toList dl) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs index eb2520cd..b3cb26a4 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs @@ -1,20 +1,32 @@ module System.Nix.Store.Remote.Types ( MonadStore + , NixRemoteError(..) + , ActivityID + , ActivityParentID + , ActivityType + , Verbosity + , ResultType , Logger(..) , Field(..) - , getLog , flushLog - , gotError - , getError) where + ) where +import Control.Exception import qualified Data.ByteString.Lazy as LBS +import Data.DList import Network.Socket (Socket) -import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State -type MonadStore a = ExceptT String (StateT [Logger] (ReaderT Socket IO)) a +type MonadStore a = StateT (DList Logger) (ReaderT Socket IO) a + +-- | Exceptions that may be thrown while interacting with the nix-daemon. +data NixRemoteError = ParseError String + | ProtocolError Int String + deriving (Show) + +instance Exception NixRemoteError type ActivityID = Int type ActivityParentID = Int @@ -36,18 +48,5 @@ data Logger = | Result ActivityID ResultType [Field] deriving (Eq, Ord, Show) -isError :: Logger -> Bool -isError (Error _ _) = True -isError _ = False - -gotError :: MonadStore Bool -gotError = any isError <$> get - -getError :: MonadStore [Logger] -getError = filter isError <$> get - -getLog :: MonadStore [Logger] -getLog = get - flushLog :: MonadStore () -flushLog = put [] +flushLog = put mempty diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Util.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Util.hs index 9717dc20..f9a0f45f 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Util.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Util.hs @@ -2,7 +2,6 @@ module System.Nix.Store.Remote.Util where import Control.Monad.Reader -import Data.Maybe import Data.Binary.Get import Data.Binary.Put import Data.Text (Text) @@ -10,12 +9,10 @@ import qualified Data.Text as T import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as LBS -import qualified Data.HashSet as HashSet import Network.Socket.ByteString (recv, sendAll) import System.Nix.Store.Remote.Types -import System.Nix.Hash import System.Nix.Util