remote: deal with Realisation.id (required for the server side and qc prop)

Author: sorki

hnix-store-core/src/System/Nix/Build.hs

@@ -15,7 +15,7 @@ import Data.Text (Text)
 import GHC.Generics (Generic)
 
 import System.Nix.OutputName (OutputName)
-import System.Nix.Realisation (Realisation)
+import System.Nix.Realisation (DerivationOutput, Realisation)
 
 -- | Mode of the build operation
 -- Keep the order of these Enums to match enums from reference implementations
@@ -59,7 +59,7 @@ data BuildResult = BuildResult
   -- ^ Start time of this build (since 1.29)
   , buildResultStopTime           :: Maybe UTCTime
   -- ^ Stop time of this build (since 1.29)
-  , buildResultBuiltOutputs       :: Maybe (Map OutputName Realisation)
+  , buildResultBuiltOutputs       :: Maybe (Map (DerivationOutput OutputName) Realisation)
   -- ^ Mapping of the output names to @Realisation@s (since 1.28)
   -- (paths with additional info and their dependencies)
   }

hnix-store-json/src/System/Nix/JSON.hs

@@ -10,14 +10,15 @@ which is required for `-remote`.
 module System.Nix.JSON where
 
 import Data.Aeson
-import Data.Aeson.Types (toJSONKeyText)
 import Deriving.Aeson
 import System.Nix.Base (BaseEncoding(NixBase32))
 import System.Nix.OutputName (OutputName)
 import System.Nix.Realisation (DerivationOutput, Realisation)
 import System.Nix.Signature (Signature)
 import System.Nix.StorePath (StoreDir(..), StorePath, StorePathName, StorePathHashPart)
 
+import qualified Data.Aeson.KeyMap
+import qualified Data.Aeson.Types
 import qualified Data.Attoparsec.Text
 import qualified Data.Char
 import qualified Data.Text
@@ -93,7 +94,7 @@ instance ToJSON (DerivationOutput OutputName) where
 
 instance ToJSONKey (DerivationOutput OutputName) where
   toJSONKey =
-    toJSONKeyText
+    Data.Aeson.Types.toJSONKeyText
     $ Data.Text.Lazy.toStrict
     . Data.Text.Lazy.Builder.toLazyText
     . System.Nix.Realisation.derivationOutputBuilder
@@ -156,3 +157,20 @@ deriving
         ]
      ] Realisation
   instance FromJSON Realisation
+
+-- For a keyed version of Realisation
+-- we use (DerivationOutput OutputName, Realisation)
+-- instead of Realisation.id :: (DerivationOutput OutputName)
+-- field.
+instance {-# OVERLAPPING #-} ToJSON (DerivationOutput OutputName, Realisation) where
+  toJSON (drvOut, r) =
+    case toJSON r of
+      Object o -> Object $ Data.Aeson.KeyMap.insert "id" (toJSON drvOut) o
+      _ -> error "absurd"
+
+instance {-# OVERLAPPING #-} FromJSON (DerivationOutput OutputName, Realisation) where
+  parseJSON v@(Object o) = do
+    r <- parseJSON @Realisation v
+    drvOut <- o .: "id"
+    pure (drvOut, r)
+  parseJSON x = fail $ "Expected Object but got " ++ show x

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

@@ -31,6 +31,8 @@ module System.Nix.Store.Remote.Serializer
   , set
   , hashSet
   , mapS
+  , vector
+  , json
   -- * ProtoVersion
   , protoVersion
   -- * StorePath
@@ -45,6 +47,7 @@ module System.Nix.Store.Remote.Serializer
   -- * Realisation
   , derivationOutputTyped
   , realisation
+  , realisationWithId
   -- * Signatures
   , signature
   , narSignature
@@ -93,6 +96,7 @@ import Control.Monad.Trans (MonadTrans, lift)
 import Control.Monad.Trans.Reader (ReaderT, runReaderT, withReaderT)
 import Control.Monad.Trans.Except (ExceptT, mapExceptT, runExceptT, withExceptT)
 import Crypto.Hash (Digest, HashAlgorithm, SHA256)
+import Data.Aeson (FromJSON, ToJSON)
 import Data.ByteString (ByteString)
 import Data.Dependent.Sum (DSum((:=>)))
 import Data.Fixed (Uni)
@@ -242,6 +246,7 @@ data SError
   | SError_HashAlgo String
   | SError_IllegalBool Word64
   | SError_InvalidNixBase32
+  | SError_JSONDecoding String
   | SError_NarHashMustBeSHA256
   | SError_NotYetImplemented String (ForPV ProtoVersion)
   | SError_Name InvalidNameError
@@ -447,6 +452,22 @@ vector =
     Data.Vector.toList
   . list
 
+json
+  :: ( FromJSON a
+     , ToJSON a
+     )
+  => NixSerializer r SError a
+json =
+  mapPrismSerializer
+    ( Data.Bifunctor.first SError_JSONDecoding
+      . Data.Aeson.eitherDecode
+    )
+    Data.Aeson.encode
+    $ mapIsoSerializer
+        Data.ByteString.Lazy.fromStrict
+        Data.ByteString.Lazy.toStrict
+        byteString
+
 -- * ProtoVersion
 
 -- protoVersion_major & 0xFF00
@@ -614,17 +635,11 @@ derivationOutputTyped =
     )
     text
 
-realisation
-  :: HasStoreDir r
-  => NixSerializer r SError Realisation
-realisation = Serializer
-  { getS = do
-      rb <- getS byteString
-      case Data.Aeson.eitherDecode (Data.ByteString.Lazy.fromStrict rb) of
-        Left e -> error e
-        Right r -> pure r
-  , putS = putS byteString . Data.ByteString.Lazy.toStrict . Data.Aeson.encode
-  }
+realisation :: NixSerializer r SError Realisation
+realisation = json
+
+realisationWithId :: NixSerializer r SError (System.Nix.Realisation.DerivationOutput OutputName, Realisation)
+realisationWithId = json
 
 -- * Signatures
 
@@ -818,9 +833,10 @@ buildResult = Serializer
         if protoVersion_minor pv >= 28
         then
             pure
-          . Data.Map.Strict.mapKeys
-              System.Nix.Realisation.derivationOutputName
-          <$> getS (mapS derivationOutputTyped realisation)
+          . Data.Map.Strict.fromList
+          . map (\(_, (a, b)) -> (a, b))
+          . Data.Map.Strict.toList
+          <$> getS (mapS derivationOutputTyped realisationWithId)
         else pure Nothing
       pure BuildResult{..}
 
@@ -835,8 +851,10 @@ buildResult = Serializer
         putS time $ Data.Maybe.fromMaybe t0 buildResultStartTime
         putS time $ Data.Maybe.fromMaybe t0 buildResultStopTime
       Control.Monad.when (protoVersion_minor pv >= 28)
-        -- TODO realisation.id
-        $ putS (mapS outputName realisation)
+        $ putS (mapS derivationOutputTyped realisationWithId)
+        $ Data.Map.Strict.fromList
+        $ map (\(a, b) -> (a, (a, b)))
+        $ Data.Map.Strict.toList
         $ Data.Maybe.fromMaybe mempty buildResultBuiltOutputs
   }
   where