mirror of
https://github.com/haskell-nix/hnix-store.git
synced 2024-09-11 18:05:56 +03:00
remote: deal with Realisation.id (required for the server side and qc prop)
This commit is contained in:
parent
f79effe092
commit
e6d21c15bc
@ -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)
|
||||
}
|
||||
|
@ -10,7 +10,6 @@ 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)
|
||||
@ -18,6 +17,8 @@ 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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user