mirror of
https://github.com/haskell-nix/hnix-store.git
synced 2024-09-11 18:05:56 +03:00
remote: complete binary -> cereal transition
This commit is contained in:
parent
655afaa2f8
commit
93d923eafb
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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 =
|
||||
|
@ -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 ()
|
||||
|
@ -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)
|
||||
|
Loading…
Reference in New Issue
Block a user