remote: complete binary -> cereal transition

hnix-store-remote/hnix-store-remote.cabal

@@ -63,7 +63,6 @@ library
   import: commons
   exposed-modules:
       System.Nix.Store.Remote
-    , System.Nix.Store.Remote.Binary
     , System.Nix.Store.Remote.Serialize
     , System.Nix.Store.Remote.Serialize.Prim
     , System.Nix.Store.Remote.Logger
@@ -77,7 +76,6 @@ library
     , hnix-store-core >= 0.8 && <0.9
     , hnix-store-nar >= 0.1
     , attoparsec
-    , binary
     , bytestring
     , cereal
     , containers

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

@@ -31,6 +31,7 @@ module System.Nix.Store.Remote
   , module System.Nix.Store.Remote.Types
   ) where
 
+import Data.ByteString (ByteString)
 import Data.Dependent.Sum (DSum((:=>)))
 import Data.HashSet (HashSet)
 import Data.Map (Map)
@@ -41,8 +42,6 @@ import qualified Data.Attoparsec.Text
 import qualified Data.Text.Encoding
 import qualified System.Nix.Hash
 --
-import qualified Data.ByteString.Lazy          as BSL
-
 import System.Nix.Derivation (Derivation)
 import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..))
 import System.Nix.Build (BuildMode, BuildResult)
@@ -50,7 +49,6 @@ import System.Nix.Hash (NamedAlgo(..), BaseEncoding(Base16), decodeDigestWith)
 import System.Nix.StorePath (StorePath, StorePathName, StorePathHashPart, InvalidPathError)
 import System.Nix.StorePath.Metadata  (Metadata(..), StorePathTrust(..))
 
-import qualified Data.Binary.Put
 import qualified Data.Map.Strict
 import qualified Data.Set
 
@@ -58,13 +56,17 @@ import qualified System.Nix.ContentAddress
 import qualified System.Nix.StorePath
 import qualified System.Nix.Signature
 
-import System.Nix.Store.Remote.Binary
 import System.Nix.Store.Remote.Types
 import System.Nix.Store.Remote.Protocol
 import System.Nix.Store.Remote.Util
 import Crypto.Hash (SHA256)
 import System.Nix.Nar (NarSource)
 
+import Data.Serialize (get)
+import qualified Data.Serialize.Put
+import qualified System.Nix.Store.Remote.Serialize as S
+import System.Nix.Store.Remote.Serialize.Prim
+
 -- | Pack `Nar` and add it to the store.
 addToStore
   :: forall a
@@ -79,7 +81,7 @@ addToStore name source recursive repair = do
     $ error "repairing is not supported when building through the Nix daemon"
 
   runOpArgsIO AddToStore $ \yield -> do
-    yield $ BSL.toStrict $ Data.Binary.Put.runPut $ do
+    yield $ Data.Serialize.Put.runPut $ do
       putText $ System.Nix.StorePath.unStorePathName name
       putBool
         $ not
@@ -112,7 +114,7 @@ addTextToStore name text references' repair = do
     putPaths storeDir references'
   sockGetPath
 
-addSignatures :: StorePath -> [BSL.ByteString] -> MonadStore ()
+addSignatures :: StorePath -> [ByteString] -> MonadStore ()
 addSignatures p signatures = do
   storeDir <- getStoreDir
   Control.Monad.void $ simpleOpArgs AddSignatures $ do
@@ -151,15 +153,15 @@ buildDerivation p drv buildMode = do
   storeDir <- getStoreDir
   runOpArgs BuildDerivation $ do
     putPath storeDir p
-    putDerivation storeDir drv
+    S.putDerivation storeDir drv
     putEnum buildMode
     -- XXX: reason for this is unknown
     -- but without it protocol just hangs waiting for
     -- more data. Needs investigation.
     -- Intentionally the only warning that should pop-up.
-    putInt (0 :: Integer)
+    putInt (0 :: Int)
 
-  getSocketIncremental getBuildResult
+  getSocketIncremental get
 
 ensurePath :: StorePath -> MonadStore ()
 ensurePath pn = do
@@ -167,7 +169,7 @@ ensurePath pn = do
   Control.Monad.void $ simpleOpArgs EnsurePath $ putPath storeDir pn
 
 -- | Find garbage collector roots.
-findRoots :: MonadStore (Map BSL.ByteString StorePath)
+findRoots :: MonadStore (Map ByteString StorePath)
 findRoots = do
   runOp FindRoots
   sd  <- getStoreDir
@@ -175,7 +177,7 @@ findRoots = do
     getSocketIncremental
     $ getMany
     $ (,)
-      <$> (BSL.fromStrict <$> getByteStringLen)
+      <$> getByteString
       <*> getPath sd
 
   r <- catRights res
@@ -241,8 +243,8 @@ queryPathInfoUncached path = do
   narBytes         <- Just <$> sockGetInt
   ultimate         <- sockGetBool
 
-  sigStrings       <- fmap bsToText <$> sockGetStrings
-  caString         <- bsToText <$> sockGetStr
+  sigStrings       <- fmap Data.Text.Encoding.decodeUtf8 <$> sockGetStrings
+  caString         <- Data.Text.Encoding.decodeUtf8 <$> sockGetStr
 
   let
       sigs = case

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

@@ -1,54 +0,0 @@
-{-|
-Description : Utilities for packing stuff
-Maintainer  : srk <srk@48.io>
-|-}
-module System.Nix.Store.Remote.Binary where
-
-import Control.Monad
-import Data.ByteString (ByteString)
-import Data.Binary.Get
-import Data.Binary.Put
-import qualified Data.ByteString.Lazy          as BSL
-
-putInt :: Integral a => a -> Put
-putInt = putWord64le . fromIntegral
-
-getInt :: Integral a => Get a
-getInt = fromIntegral <$> getWord64le
-
-putMany :: Foldable t => (a -> Put) -> t a -> Put
-putMany printer xs = do
-  putInt (length xs)
-  mapM_ printer xs
-
-getMany :: Get a -> Get [a]
-getMany parser = do
-  count <- getInt
-  replicateM count parser
-
--- length prefixed string packing with padding to 8 bytes
-putByteStringLen :: BSL.ByteString -> Put
-putByteStringLen x = do
-  putInt len
-  putLazyByteString x
-  when (len `mod` 8 /= 0) $ pad $ 8 - (len `mod` 8)
- where
-  len :: Int
-  len = fromIntegral $ BSL.length x
-  pad count = replicateM_ count (putWord8 0)
-
-putByteStrings :: Foldable t => t BSL.ByteString -> Put
-putByteStrings = putMany putByteStringLen
-
-getByteStringLen :: Get ByteString
-getByteStringLen = do
-  len <- getInt
-  st  <- getLazyByteString len
-  when (len `mod` 8 /= 0) $ do
-    pads <- unpad $ fromIntegral $ 8 - (len `mod` 8)
-    unless (all (== 0) pads) $ fail $ "No zeroes" <> show (st, len, pads)
-  pure $ BSL.toStrict st
-  where unpad x = replicateM x getWord8
-
-getByteStrings :: Get [ByteString]
-getByteStrings = getMany getByteStringLen

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

@@ -9,28 +9,30 @@ import Control.Monad.Except (throwError)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Reader (asks)
 import Control.Monad.State.Strict (get)
-import Data.Binary.Get
+import Data.ByteString (ByteString)
+import Data.Serialize.Get (Get, Result(..))
 import Network.Socket.ByteString (recv)
-import System.Nix.Store.Remote.Binary
+import System.Nix.Store.Remote.Serialize.Prim
 import System.Nix.Store.Remote.Types
 import System.Nix.Store.Remote.Util
 
 import qualified Control.Monad
+import qualified Data.Serialize.Get
 
 controlParser :: Get Logger
 controlParser = do
   ctrl <- getInt
   case (ctrl :: Int) of
-    0x6f6c6d67 -> Next          <$> getByteStringLen
+    0x6f6c6d67 -> Next          <$> getByteString
     0x64617461 -> Read          <$> getInt
-    0x64617416 -> Write         <$> getByteStringLen
+    0x64617416 -> Write         <$> getByteString
     0x616c7473 -> pure Last
-    0x63787470 -> flip Error    <$> getByteStringLen
+    0x63787470 -> flip Error    <$> getByteString
                                 <*> getInt
     0x53545254 -> StartActivity <$> getInt
                                 <*> getInt
                                 <*> getInt
-                                <*> getByteStringLen
+                                <*> getByteString
                                 <*> getFields
                                 <*> getInt
     0x53544f50 -> StopActivity  <$> getInt
@@ -40,11 +42,16 @@ controlParser = do
     x          -> fail          $ "Invalid control message received:" <> show x
 
 processOutput :: MonadStore [Logger]
-processOutput = go decoder
+processOutput = do
+ sockGet8 >>= go . decoder
  where
-  decoder = runGetIncremental controlParser
-  go :: Decoder Logger -> MonadStore [Logger]
-  go (Done _leftover _consumed ctrl) = do
+  sockGet8 :: MonadStore ByteString
+  sockGet8 = do
+    soc <- asks storeSocket
+    liftIO $ recv soc 8
+  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]
@@ -54,21 +61,20 @@ processOutput = go decoder
           Nothing   -> throwError "No data to read provided"
           Just part -> do
             -- XXX: we should check/assert part size against n of (Read n)
-            sockPut $ putByteStringLen part
+            sockPut $ putByteString part
             clearData
 
-        go decoder
+        sockGet8 >>= go . decoder
 
       -- we should probably handle Read here as well
       x -> do
-        next <- go decoder
+        next <- sockGet8 >>= go . decoder
         pure $ x : next
   go (Partial k) = do
-    soc   <- asks storeSocket
-    chunk <- liftIO (Just <$> recv soc 8)
+    chunk <- sockGet8
     go (k chunk)
 
-  go (Fail _leftover _consumed msg) = error msg
+  go (Fail msg _leftover) = error msg
 
 getFields :: Get [Field]
 getFields = do
@@ -80,5 +86,5 @@ getField = do
   typ <- getInt
   case (typ :: Int) of
     0 -> LogInt <$> getInt
-    1 -> LogStr <$> getByteStringLen
+    1 -> LogStr <$> getByteString
     x -> fail $ "Unknown log type: " <> show x

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

@@ -23,18 +23,17 @@ import Control.Monad.State.Strict
 
 import Data.Default.Class (Default(def))
 import qualified Data.Bool
-import Data.Binary.Get
-import Data.Binary.Put
+import Data.Serialize.Get
+import Data.Serialize.Put
 import qualified Data.ByteString
 import qualified Data.ByteString.Char8
-import qualified Data.ByteString.Lazy
 
 import Network.Socket (SockAddr(SockAddrUnix))
 import qualified Network.Socket as S
 import Network.Socket.ByteString (recv, sendAll)
 
 import System.Nix.StorePath (StoreDir(..))
-import System.Nix.Store.Remote.Binary
+import System.Nix.Store.Remote.Serialize.Prim
 import System.Nix.Store.Remote.Logger
 import System.Nix.Store.Remote.Types hiding (protoVersion)
 import System.Nix.Store.Remote.Util
@@ -134,7 +133,7 @@ runOpArgs :: WorkerOp -> Put -> MonadStore ()
 runOpArgs op args =
   runOpArgsIO
     op
-    (\encode -> encode $ Data.ByteString.Lazy.toStrict $ runPut args)
+    (\encode -> encode $ runPut args)
 
 runOpArgsIO
   :: WorkerOp
@@ -187,12 +186,16 @@ runStoreOpts' sockFamily sockAddr storeRootDir code =
     soc      <- asks storeSocket
     vermagic <- liftIO $ recv soc 16
     let
-      (magic2, _daemonProtoVersion) =
-        flip runGet (Data.ByteString.Lazy.fromStrict vermagic)
+      eres =
+        flip runGet vermagic
           $ (,)
             <$> (getInt :: Get Int)
             <*> (getInt :: Get Int)
-    Control.Monad.unless (magic2 == workerMagic2) $ error "Worker magic 2 mismatch"
+
+    case eres of
+      Left err -> error $ "Error parsing vermagic " ++ err
+      Right (magic2, _daemonProtoVersion) -> do
+        Control.Monad.unless (magic2 == workerMagic2) $ error "Worker magic 2 mismatch"
 
     sockPut $ putInt protoVersion -- clientVersion
     sockPut $ putInt (0 :: Int)   -- affinity

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

@@ -37,7 +37,7 @@ instance Serialize BuildResult where
   get = do
     status <- get
     errorMessage <-
-      (\em -> Data.Bool.bool (Just em) Nothing (Data.Text.null em)) 
+      (\em -> Data.Bool.bool (Just em) Nothing (Data.Text.null em))
       <$> get
     timesBuilt <- getInt
     isNonDeterministic <- getBool

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

@@ -14,6 +14,7 @@ import Data.Time (NominalDiffTime, UTCTime)
 import System.Nix.StorePath (StoreDir, StorePath, InvalidPathError)
 
 import qualified Control.Monad
+import qualified Data.Either
 import qualified Data.HashSet
 import qualified Data.Serialize.Get
 import qualified Data.Serialize.Put
@@ -179,6 +180,19 @@ getPaths sd =
   . fmap (System.Nix.StorePath.parsePath sd)
   <$> getByteStrings
 
+-- | Deserialize @StorePath@, checking
+-- that @StoreDir@ matches expected value
+getPathsOrFail :: StoreDir -> Get (HashSet StorePath)
+getPathsOrFail sd = do
+  eps <-
+    fmap (System.Nix.StorePath.parsePath sd)
+    <$> getByteStrings
+  Control.Monad.when (any Data.Either.isLeft eps)
+    $ fail
+    $ show
+    $ Data.Either.lefts eps
+  pure $ Data.HashSet.fromList $ Data.Either.rights eps
+
 -- | Serialize a @HashSet@ of @StorePath@s
 putPaths :: StoreDir -> Putter (HashSet StorePath)
 putPaths storeDir =

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

@@ -30,8 +30,6 @@ import Control.Monad.State.Strict (StateT, gets, modify)
 import Data.ByteString (ByteString)
 import Network.Socket (Socket)
 
-import qualified Data.ByteString.Lazy as BSL
-
 import Control.Monad.Trans.State.Strict (mapStateT)
 import Control.Monad.Trans.Except (mapExceptT)
 import Control.Monad.Trans.Reader (withReaderT)
@@ -68,7 +66,7 @@ getStoreDir' = asks hasStoreDir
 type MonadStore a
   = ExceptT
       String
-      (StateT (Maybe BSL.ByteString, [Logger]) (ReaderT StoreConfig IO))
+      (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
       a
 
 -- | For lying about the store dir in tests
@@ -111,7 +109,7 @@ getLog = gets snd
 flushLog :: MonadStore ()
 flushLog = modify (\(a, _b) -> (a, []))
 
-setData :: BSL.ByteString -> MonadStore ()
+setData :: ByteString -> MonadStore ()
 setData x = modify (\(_, b) -> (Just x, b))
 
 clearData :: MonadStore ()

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

@@ -5,72 +5,64 @@ import Control.Monad.Reader (asks)
 import Control.Monad.IO.Class (MonadIO(..))
 import Data.ByteString (ByteString)
 import Data.HashSet (HashSet)
-import Data.Text (Text)
-import Data.Either (rights)
-
-import Data.Binary.Get
-import Data.Binary.Put
-import qualified Data.Text.Encoding as T
-import qualified Data.Text.Lazy as TL
-import qualified Data.Text.Lazy.Encoding as TL
-import Data.Time
-import Data.Time.Clock.POSIX
-import qualified Data.ByteString.Char8 as BSC
-import qualified Data.ByteString.Lazy as BSL
 
+import Data.Serialize.Get (Get, Result(..))
+import Data.Serialize.Put
 import Network.Socket.ByteString (recv, sendAll)
 
-import System.Nix.Build
-import System.Nix.Derivation
-import System.Nix.StorePath (StoreDir, StorePath, InvalidPathError, parsePath, storePathToRawFilePath)
-import System.Nix.Store.Remote.Binary
+import System.Nix.StorePath (StorePath)
 import System.Nix.Store.Remote.Types
 
-import qualified Data.HashSet
-import qualified Data.Map
+import qualified System.Nix.Store.Remote.Serialize.Prim as P
+import qualified Data.Serialize.Get
 
-genericIncremental :: (MonadIO m) => m (Maybe ByteString) -> Get a -> m a
-genericIncremental getsome parser = go decoder
+genericIncremental
+  :: MonadIO m
+  => m ByteString
+  -> Get a
+  -> m a
+genericIncremental getsome parser = do
+  getsome >>= go . decoder
  where
-  decoder = runGetIncremental parser
-  go (Done _leftover _consumed x  ) = pure x
-  go (Partial k                   ) = do
+  decoder = Data.Serialize.Get.runGetPartial parser
+  go (Done x _leftover) = pure x
+  go (Partial k) = do
     chunk <- getsome
     go (k chunk)
-  go (Fail _leftover _consumed msg) = error msg
+  go (Fail msg _leftover) = error msg
 
 getSocketIncremental :: Get a -> MonadStore a
 getSocketIncremental = genericIncremental sockGet8
  where
-  sockGet8 :: MonadStore (Maybe BSC.ByteString)
+  sockGet8 :: MonadStore ByteString
   sockGet8 = do
     soc <- asks storeSocket
-    liftIO $ Just <$> recv soc 8
+    liftIO $ recv soc 8
 
 sockPut :: Put -> MonadStore ()
 sockPut p = do
   soc <- asks storeSocket
-  liftIO $ sendAll soc $ BSL.toStrict $ runPut p
+  liftIO $ sendAll soc $ runPut p
 
 sockGet :: Get a -> MonadStore a
 sockGet = getSocketIncremental
 
 sockGetInt :: Integral a => MonadStore a
-sockGetInt = getSocketIncremental getInt
+sockGetInt = fromIntegral <$> getSocketIncremental P.getInt
 
 sockGetBool :: MonadStore Bool
 sockGetBool = (== (1 :: Int)) <$> sockGetInt
 
 sockGetStr :: MonadStore ByteString
-sockGetStr = getSocketIncremental getByteStringLen
+sockGetStr = getSocketIncremental P.getByteString
 
 sockGetStrings :: MonadStore [ByteString]
-sockGetStrings = getSocketIncremental getByteStrings
+sockGetStrings = getSocketIncremental P.getByteStrings
 
 sockGetPath :: MonadStore StorePath
 sockGetPath = do
   sd  <- getStoreDir
-  pth <- getSocketIncremental (getPath sd)
+  pth <- getSocketIncremental (P.getPath sd)
   either
     (throwError . show)
     pure
@@ -79,7 +71,7 @@ sockGetPath = do
 sockGetPathMay :: MonadStore (Maybe StorePath)
 sockGetPathMay = do
   sd  <- getStoreDir
-  pth <- getSocketIncremental (getPath sd)
+  pth <- getSocketIncremental (P.getPath sd)
   pure $
     either
       (const Nothing)
@@ -89,82 +81,4 @@ sockGetPathMay = do
 sockGetPaths :: MonadStore (HashSet StorePath)
 sockGetPaths = do
   sd <- getStoreDir
-  getSocketIncremental (getPaths sd)
-
-bsToText :: ByteString -> Text
-bsToText = T.decodeUtf8
-
-textToBS :: Text -> ByteString
-textToBS = T.encodeUtf8
-
-bslToText :: BSL.ByteString -> Text
-bslToText = TL.toStrict . TL.decodeUtf8
-
-textToBSL :: Text -> BSL.ByteString
-textToBSL = TL.encodeUtf8 . TL.fromStrict
-
-putText :: Text -> Put
-putText = putByteStringLen . textToBSL
-
-putTexts :: [Text] -> Put
-putTexts = putByteStrings . fmap textToBSL
-
-getPath :: StoreDir -> Get (Either InvalidPathError StorePath)
-getPath sd = parsePath sd <$> getByteStringLen
-
-getPaths :: StoreDir -> Get (HashSet StorePath)
-getPaths sd =
-  Data.HashSet.fromList . rights . fmap (parsePath sd) <$> getByteStrings
-
-putPath :: StoreDir -> StorePath -> Put
-putPath storeDir = putByteStringLen . BSL.fromStrict . storePathToRawFilePath storeDir
-
-putPaths :: StoreDir -> HashSet StorePath -> Put
-putPaths storeDir = putByteStrings . Data.HashSet.toList . Data.HashSet.map
-  (BSL.fromStrict . storePathToRawFilePath storeDir)
-
-putBool :: Bool -> Put
-putBool True  = putInt (1 :: Int)
-putBool False = putInt (0 :: Int)
-
-getBool :: Get Bool
-getBool = (== 1) <$> (getInt :: Get Int)
-
-putEnum :: (Enum a) => a -> Put
-putEnum = putInt . fromEnum
-
-getEnum :: (Enum a) => Get a
-getEnum = toEnum <$> getInt
-
-putTime :: UTCTime -> Put
-putTime = (putInt :: Int -> Put) . round . utcTimeToPOSIXSeconds
-
-getTime :: Get UTCTime
-getTime = posixSecondsToUTCTime <$> getEnum
-
-getBuildResult :: Get BuildResult
-getBuildResult =
-  BuildResult
-    <$> getEnum
-    <*> (Just . bsToText <$> getByteStringLen)
-    <*> getInt
-    <*> getBool
-    <*> getTime
-    <*> getTime
-
-putDerivation :: StoreDir -> Derivation StorePath Text -> Put
-putDerivation storeDir Derivation{..} = do
-  flip putMany (Data.Map.toList outputs)
-    $ \(outputName, DerivationOutput{..}) -> do
-        putText outputName
-        putPath storeDir path
-        putText hashAlgo
-        putText hash
-
-  putMany (putPath storeDir) inputSrcs
-  putText platform
-  putText builder
-  putMany putText args
-
-  flip putMany (Data.Map.toList env)
-    $ \(a1, a2) -> putText a1 *> putText a2
+  getSocketIncremental (P.getPathsOrFail sd)