add Serialize for Derivation, add getPathOrFail

Author: sorki

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

@@ -93,6 +93,7 @@ library
     , unordered-containers
     , hnix-store-core >= 0.7 && <0.8
     , transformers
+    , vector
   hs-source-dirs:      src
   ghc-options:         -Wall
 
@@ -117,6 +118,7 @@ test-suite remote
   build-depends:
       hnix-store-core
     , hnix-store-remote
+    , nix-derivation
     , bytestring
     , cereal
     , text

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

@@ -6,12 +6,19 @@ Maintainer  : srk <[email protected]>
 module System.Nix.Store.Remote.Serialize where
 
 import Data.Serialize (Serialize(..))
+import Data.Serialize.Get (Get)
+import Data.Serialize.Put (Putter)
 import Data.Text (Text)
 
 import qualified Data.Bool
+import qualified Data.Map
+import qualified Data.Set
 import qualified Data.Text
+import qualified Data.Vector
 
+import Nix.Derivation (Derivation(..), DerivationOutput(..))
 import System.Nix.Build (BuildMode(..), BuildStatus(..), BuildResult(..))
+import System.Nix.StorePath (StoreDir, StorePath)
 import System.Nix.Store.Remote.Serialize.Prim
 
 instance Serialize Text where
@@ -47,3 +54,53 @@ instance Serialize BuildResult where
     putBool isNonDeterministic
     putTime startTime
     putTime stopTime
+
+getDerivation
+  :: StoreDir
+  -> Get (Derivation StorePath Text)
+getDerivation storeDir = do
+  outputs <-
+    Data.Map.fromList
+    <$> (getMany $ do
+          outputName <- get
+          path <- getPathOrFail storeDir
+          hashAlgo <- get
+          hash <- get
+          pure (outputName, DerivationOutput{..})
+        )
+
+  -- Our type is Derivation, but in Nix
+  -- the type sent over the wire is BasicDerivation
+  -- which omits inputDrvs
+  inputDrvs <- pure mempty
+  inputSrcs <-
+    Data.Set.fromList
+    <$> getMany (getPathOrFail storeDir)
+
+  platform <- get
+  builder <- get
+  args <-
+    Data.Vector.fromList
+    <$> getMany get
+
+  env <-
+    Data.Map.fromList
+    <$> getMany ((,) <$> get <*> get)
+  pure Derivation{..}
+
+putDerivation :: StoreDir -> Putter (Derivation StorePath Text)
+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

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

@@ -157,6 +157,15 @@ getPath :: StoreDir -> Get (Either InvalidPathError StorePath)
 getPath sd =
   System.Nix.StorePath.parsePath sd <$> getByteString
 
+-- | Deserialize @StorePath@, checking
+-- that @StoreDir@ matches expected value
+getPathOrFail :: StoreDir -> Get StorePath
+getPathOrFail sd =
+  getPath sd
+  >>= either
+    (fail . show)
+    pure
+
 -- | Serialize @StorePath@ with its associated @StoreDir@
 putPath :: StoreDir -> Putter StorePath
 putPath storeDir =

hnix-store-remote/tests/SerializeSpec.hs

@@ -18,9 +18,11 @@ import qualified Data.HashSet
 import qualified Data.Time.Clock.POSIX
 import qualified System.Nix.Build
 
-import System.Nix.Build (BuildMode, BuildStatus, BuildResult)
+import Nix.Derivation (Derivation(..))
+import System.Nix.Build (BuildMode, BuildStatus)
+import System.Nix.Derivation ()
 import System.Nix.StorePath (StoreDir, StorePath)
-import System.Nix.Store.Remote.Serialize ()
+import System.Nix.Store.Remote.Serialize (getDerivation, putDerivation)
 import System.Nix.Store.Remote.Serialize.Prim
 
 roundTrip :: (Eq a, Show a) => Putter a -> Get a -> a -> Property
@@ -145,3 +147,13 @@ spec_buildEnums =
       it' "NotDeterministic"       System.Nix.Build.NotDeterministic       12
       it' "ResolvesToAlreadyValid" System.Nix.Build.ResolvesToAlreadyValid 13
       it' "NoSubstituters"         System.Nix.Build.NoSubstituters         14
+
+-- ** Derivation
+
+prop_derivation :: StoreDir -> Derivation StorePath Text -> Property
+prop_derivation sd drv =
+  roundTrip
+    (putDerivation sd)
+    (getDerivation sd)
+    -- inputDrvs is not used in remote protocol serialization
+    (drv { inputDrvs = mempty })