diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,24 @@ +# [0.8.0.0](https://github.com/haskell-nix/hnix-store/compare/remote-0.7.0.0...remote-0.8.0.0) 2026-10-21 + +* Changes: + * Make `putS` infallible (`a -> PutM ()` instead of `a -> t PutM ()`) + * Remove `SerialT` reader monad; `StoreDir` and `ProtoVersion` are now passed as explicit parameters + * Add `AlmostPrism` type and rewrite `mapPrismSerializer` + * Add `depTup`, `mapS'`, `maybeByteString` combinators to `Data.Serializer` + * Update `buildResult` serializer for new `BuildSuccess`/`BuildFailure` types + * Update `buildTraceKeyTyped` serializer for `StorePath`-based `BuildTraceKey` + * New dependency: `mmorph` + * Protocol version updated to 1.38 + * `ProtoVersion` now includes `protoVersion_features :: Set ProtoFeature` for feature negotiation + * Feature negotiation during handshake (client and server) when both sides >= 1.38 + * `PartialOrd` replaces `Ord` on `ProtoVersion` (from `lattices`) + * New dependency: `lattices` + * Support for the `builder-rpc-v0` interface + * New `SubmitOutput` (1000) and `AddToStoreScanning` (1001) operations, with `submitOutput` and `addToStoreScanning` client functions + * `builderRpcV0` constant for the pinned profile, set it as the client's `ProtoVersion` before the handshake + * `WorkerOp` wire mapping now goes through `workerOpToWord64` and `word64ToWorkerOp` since opcodes are no longer contiguous + * New `singleDerivedPath` serializer + # [0.7.0.0](https://github.com/haskell-nix/hnix-store/compare/remote-0.6.0.0...remote-0.7.0.0) 2024-07-31 * Changes: diff --git a/app/BuildDerivation.hs b/app/BuildDerivation.hs --- a/app/BuildDerivation.hs +++ b/app/BuildDerivation.hs @@ -3,11 +3,11 @@ import Data.Default.Class (Default(def)) -import qualified Data.Text -import qualified System.Environment -import qualified System.Nix.Build -import qualified System.Nix.StorePath -import qualified System.Nix.Store.Remote +import Data.Text qualified +import System.Environment qualified +import System.Nix.Build qualified +import System.Nix.StorePath qualified +import System.Nix.Store.Remote qualified main :: IO () main = System.Environment.getArgs >>= \case diff --git a/hnix-store-remote.cabal b/hnix-store-remote.cabal --- a/hnix-store-remote.cabal +++ b/hnix-store-remote.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hnix-store-remote -version: 0.7.0.0 +version: 0.8.0.0 synopsis: Remote hnix store description: Implementation of the nix store using the daemon protocol. homepage: https://github.com/haskell-nix/hnix-store @@ -31,6 +31,7 @@ , DerivingVia , FlexibleContexts , FlexibleInstances + , ImportQualifiedPost , GADTs , RecordWildCards , ScopedTypeVariables @@ -103,10 +104,11 @@ build-depends: base >=4.12 && <5 - , hnix-store-core >= 0.8 && <0.9 - , hnix-store-json >= 0.1 + , hnix-store-core >= 0.9 && <0.10 + , hnix-store-json >= 0.2 , hnix-store-nar >= 0.1 - , hnix-store-tests >= 0.1 + , hnix-store-tests >= 0.2 + , hnix-store-aterm , aeson , attoparsec , bytestring @@ -122,6 +124,8 @@ , exceptions , generic-arbitrary < 1.1 , hashable + , lattices + , mmorph , text , time , transformers @@ -135,6 +139,7 @@ ghc-options: -Wall executable build-derivation + import: commons if !flag(build-derivation) buildable: False build-depends: @@ -143,12 +148,12 @@ , hnix-store-remote , data-default-class , text - default-language: Haskell2010 main-is: BuildDerivation.hs hs-source-dirs: app ghc-options: -Wall -threaded -rtsopts "-with-rtsopts -N" executable remote-readme + import: commons if !flag(build-readme) buildable: False build-depends: @@ -157,7 +162,6 @@ , hnix-store-remote build-tool-depends: markdown-unlit:markdown-unlit - default-language: Haskell2010 main-is: README.lhs ghc-options: -pgmL markdown-unlit -Wall @@ -178,12 +182,14 @@ , hnix-store-core , hnix-store-remote , hnix-store-tests - , bytestring + , hnix-store-aterm + , containers , crypton , some > 1.0.5 && < 2 - , time , hspec , QuickCheck + , time + , transformers test-suite remote-io import: commons diff --git a/src/Data/Serializer.hs b/src/Data/Serializer.hs --- a/src/Data/Serializer.hs +++ b/src/Data/Serializer.hs @@ -29,18 +29,19 @@ , SimpleSerializer -- ** Simple runners , runGetSimple - , runPutSimple -- * From Get/Put, Serialize , lift2 , liftSerialize -- * Combinators + , AlmostPrism(..) + , maybeAlmostPrism , mapIsoSerializer , mapPrismSerializer , tup + , depTup -- * Utility , GetSerializerError(..) , transformGetError - , transformPutError -- * Re-exports , Get , PutM @@ -49,16 +50,15 @@ #if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) #endif -import Control.Monad.Except (MonadError, throwError) -import Control.Monad.Trans (lift) -import Control.Monad.Trans (MonadTrans) +import Control.Monad.Morph import Control.Monad.Trans.Identity (IdentityT, runIdentityT) import Data.ByteString (ByteString) +import Data.Functor.Identity import Data.Serialize (Serialize) +import Data.Serialize qualified import Data.Serialize.Get (Get, runGet) import Data.Serialize.Put (Putter, PutM, runPutM) -import qualified Data.Serialize -- * Serializer @@ -68,21 +68,17 @@ -- for e.g. adding @ExceptT@ or @ReaderT@ layers. data Serializer t a = Serializer { getS :: t Get a - , putS :: a -> t PutM () + , putS :: a -> PutM () } -- ** Runners -- | Runner for putS of @Serializer@ runPutS - :: ( Monad (t PutM) - , MonadTrans t - ) - => Serializer t a -- ^ Serializer - -> (t PutM () -> PutM b) -- ^ Tranformer runner + :: Serializer t a -- ^ Serializer -> a -- ^ Value to (out)put - -> (b, ByteString) -runPutS s run a = runPutM $ run $ (putS s) a + -> ByteString +runPutS s = snd . runPutM . putS s -- | Runner for getS of @Serializer@ runGetS @@ -110,15 +106,6 @@ runGetSimple s b = runGetS s (runIdentityT) b --- | Runner for putS of @SimpleSerializer@ -runPutSimple - :: SimpleSerializer a - -> a - -> ByteString -runPutSimple s = - snd - . runPutS s runIdentityT - -- * From Get/Put, Serialize -- | Lift @Get a@ and @Putter a@ into @Serializer@ @@ -130,7 +117,7 @@ -> Serializer t a lift2 f g = Serializer { getS = lift f - , putS = lift . g + , putS = g } -- | Lift @Serialize a@ instance into @Serializer@ @@ -158,17 +145,34 @@ , putS = putS s . g } +data AlmostPrism t a b = AlmostPrism + { _almostPrism_get :: a -> t Identity b + -- ^ Map over @getS@ + , _almostPrism_put :: b -> a + -- ^ Map over @putS@ + } + +maybeAlmostPrism + :: Applicative (t Identity) + => AlmostPrism t a b + -> AlmostPrism t (Maybe a) (Maybe b) +maybeAlmostPrism ap = AlmostPrism + { _almostPrism_get = traverse $ _almostPrism_get ap + , _almostPrism_put = fmap $ _almostPrism_put ap + } + -- | Map over @Serializer@ where @getS@ -- can return @Either@ mapPrismSerializer - :: MonadError eGet (t Get) - => (a -> Either eGet b) -- ^ Map over @getS@ - -> (b -> a) -- ^ Map over @putS@ + :: ( Monad (t Get) + , MFunctor t + ) + => AlmostPrism t a b -> Serializer t a -> Serializer t b -mapPrismSerializer f g s = Serializer - { getS = either throwError pure . f =<< getS s - , putS = putS s . g +mapPrismSerializer p s = Serializer + { getS = hoist generalize . _almostPrism_get p =<< getS s + , putS = putS s . _almostPrism_put p } -- | Tuple combinator @@ -186,6 +190,24 @@ putS b y } +-- | Dependent tuple combinator +depTup + :: ( Monad (t Get) + , Monad (t PutM) + ) + => Serializer t a + -> (a -> Serializer t b) + -> Serializer t (a, b) +depTup sa sb = Serializer + { getS = do + a <- getS sa + b <- getS $ sb a + pure (a, b) + , putS = \(x, y) -> do + putS sa x + putS (sb x) y + } + -- * Utilities -- | Wrapper for both GetS errors @@ -206,9 +228,3 @@ Left stringyRunGetError -> Left (SerializerError_GetFail stringyRunGetError) Right (Left myGetError) -> Left (SerializerError_Get myGetError) Right (Right res) -> Right res - --- | Helper for transforming @runPutM@ result -transformPutError - :: (Either customPutError (), ByteString) - -> Either customPutError ByteString -transformPutError (e, r) = either Left (pure $ Right r) e diff --git a/src/Data/Serializer/Example.hs b/src/Data/Serializer/Example.hs --- a/src/Data/Serializer/Example.hs +++ b/src/Data/Serializer/Example.hs @@ -11,16 +11,11 @@ , runP -- * Custom errors , MyGetError(..) - , MyPutError(..) -- ** Erroring variants of cmdS - -- *** putS with throwError and MyPutError - , cmdSPutError -- *** getS with throwError and MyGetError , cmdSGetError -- *** getS with fail , cmdSGetFail - -- *** putS with fail - , cmdSPutFail -- * Elaborate , cmdSRest , runGRest @@ -28,13 +23,13 @@ ) where import Control.Monad.Except (MonadError, throwError) -import Control.Monad.Reader (MonadReader, ask) +import Control.Monad.Reader (MonadReader) import Control.Monad.State (MonadState) import Control.Monad.Trans (MonadTrans, lift) import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Trans.State (StateT, runStateT) -import Data.Bifunctor (first, second) +import Data.Bifunctor (second) import Data.ByteString (ByteString) import Data.Int (Int8) import Data.GADT.Show (GShow(..), defaultGshowsPrec) @@ -48,7 +43,6 @@ , runGetS , runPutS , transformGetError - , transformPutError ) import Data.Some (Some(..)) import GHC.Generics (Generic) @@ -97,25 +91,25 @@ opcode :: MonadTrans t => Serializer t OpCode opcode = Serializer { getS = lift getEnum - , putS = lift . putEnum + , putS = putEnum } -- * Cmd Serializer -- | @Cmd@ @Serializer@ cmdS - :: forall t . ( MonadTrans t - , Monad (t Get) - , Monad (t PutM) - ) + :: forall t + . ( MonadTrans t + , Monad (t Get) + ) => Serializer t (Some Cmd) cmdS = Serializer { getS = getS opcode >>= \case OpCode_Int -> Some . Cmd_Int <$> lift getInt8 OpCode_Bool -> Some . Cmd_Bool <$> lift getBool , putS = \case - Some (Cmd_Int i) -> putS opcode OpCode_Int >> lift (putInt8 i) - Some (Cmd_Bool b) -> putS opcode OpCode_Bool >> lift (putBool b) + Some (Cmd_Int i) -> putS (opcode @t) OpCode_Int >> putInt8 i + Some (Cmd_Bool b) -> putS (opcode @t) OpCode_Bool >> putBool b } -- * Runners @@ -133,10 +127,8 @@ runP :: Serializer (ExceptT e) a -> a - -> Either e ByteString -runP s = - (\(e, r) -> either Left (pure $ Right r) e) - . runPutS s runExceptT + -> ByteString +runP = runPutS -- * Custom errors @@ -144,22 +136,8 @@ = MyGetError_Example deriving (Eq, Show) -data MyPutError - = MyPutError_NoLongerSupported -- no longer supported protocol version - deriving (Eq, Show) - -- ** Erroring variants of cmdS --- *** putS with throwError and MyPutError - -cmdSPutError :: Serializer (ExceptT MyPutError) (Some Cmd) -cmdSPutError = Serializer - { getS = getS cmdS - , putS = \case - Some (Cmd_Int i) -> putS opcode OpCode_Int >> lift (putInt8 i) - Some (Cmd_Bool _b) -> throwError MyPutError_NoLongerSupported - } - -- *** getS with throwError and MyGetError cmdSGetError :: Serializer (ExceptT MyGetError) (Some Cmd) @@ -167,13 +145,14 @@ { getS = getS opcode >>= \case OpCode_Int -> Some . Cmd_Int <$> lift getInt8 OpCode_Bool -> throwError MyGetError_Example - , putS = putS cmdS + , putS = putS $ cmdS @(ExceptT MyGetError) } -- *** getS with fail cmdSGetFail - :: ( MonadTrans t + :: forall t + . ( MonadTrans t , MonadFail (t Get) , Monad (t PutM) ) @@ -182,26 +161,7 @@ { getS = getS opcode >>= \case OpCode_Int -> Some . Cmd_Int <$> lift getInt8 OpCode_Bool -> fail "no parse" - , putS = putS cmdS - } - --- *** putS with fail - --- | Unused as PutM doesn't have @MonadFail@ --- >>> serializerPutFail = cmdPutFail @(ExceptT MyGetError) --- No instance for (MonadFail PutM) --- as expected -cmdSPutFail - :: ( MonadTrans t - , MonadFail (t PutM) - , Monad (t Get) - ) - => Serializer t (Some Cmd) -cmdSPutFail = Serializer - { getS = getS cmdS - , putS = \case - Some (Cmd_Int i) -> putS opcode OpCode_Int >> lift (putInt8 i) - Some (Cmd_Bool _b) -> fail "can't" + , putS = putS $ cmdS @t } -- * Elaborate @@ -250,35 +210,29 @@ runPRest :: Serializer (REST r e s) a - -> r - -> s -> a - -> Either e ByteString -runPRest serializer r s = - transformPutError - . first fst - . runPutS - serializer - (restRunner r s) + -> ByteString +runPRest = runPutS cmdSRest - :: Serializer (REST Bool e Int) (Some Cmd) -cmdSRest = Serializer + :: forall t e + . t ~ REST Bool e Int + => Bool + -> Serializer t (Some Cmd) +cmdSRest isTrue = Serializer { getS = getS opcode >>= \case OpCode_Int -> do - isTrue <- ask if isTrue then Some . Cmd_Int . (+1) <$> lift getInt8 else Some . Cmd_Int <$> lift getInt8 OpCode_Bool -> Some . Cmd_Bool <$> lift getBool , putS = \case Some (Cmd_Int i) -> do - putS opcode OpCode_Int - isTrue <- ask + putS (opcode @t) OpCode_Int if isTrue - then lift (putInt8 (i - 1)) - else lift (putInt8 i) - Some (Cmd_Bool b) -> putS opcode OpCode_Bool >> lift (putBool b) + then putInt8 (i - 1) + else putInt8 i + Some (Cmd_Bool b) -> putS (opcode @t) OpCode_Bool >> putBool b } -- Primitives helpers diff --git a/src/System/Nix/Store/Remote.hs b/src/System/Nix/Store/Remote.hs --- a/src/System/Nix/Store/Remote.hs +++ b/src/System/Nix/Store/Remote.hs @@ -23,7 +23,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Default.Class (Default(def)) import Network.Socket (Family, SockAddr(SockAddrUnix)) -import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..)) +import System.Nix.Store.Types (RepairMode(..)) import System.Nix.Store.Remote.MonadStore ( runRemoteStoreT , MonadRemoteStore(..) @@ -33,14 +33,14 @@ import System.Nix.Store.Remote.Server (WorkerHelper, runProxyDaemon) import System.Nix.Store.Remote.Types -import qualified Control.Monad.Catch -import qualified Network.Socket +import Control.Monad.Catch qualified +import Network.Socket qualified -- see TODO bellow ---import qualified System.Directory +--import System.Directory qualified -- wip justdoit import System.Nix.StorePath (StorePath) -import qualified System.Nix.StorePath +import System.Nix.StorePath qualified -- * Compat diff --git a/src/System/Nix/Store/Remote/Arbitrary.hs b/src/System/Nix/Store/Remote/Arbitrary.hs --- a/src/System/Nix/Store/Remote/Arbitrary.hs +++ b/src/System/Nix/Store/Remote/Arbitrary.hs @@ -5,10 +5,12 @@ import Data.Some (Some(Some)) import System.Nix.Arbitrary () +import System.Nix.Derivation (Derivation'(..)) +import System.Nix.StorePath (StorePath(..)) import System.Nix.Store.Types (RepairMode(..)) import System.Nix.Store.Remote.Types -import Test.QuickCheck (Arbitrary(..), oneof, suchThat) +import Test.QuickCheck (Arbitrary(..), arbitraryBoundedEnum, oneof, suchThat) import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..)) deriving via GenericArbitrary CheckMode @@ -20,9 +22,14 @@ deriving via GenericArbitrary ProtoStoreConfig instance Arbitrary ProtoStoreConfig -deriving via GenericArbitrary ProtoVersion - instance Arbitrary ProtoVersion +-- Custom instance: major is always 1 (the only real protocol major version), +-- features are always empty (features are exchanged separately, not in wire format). +instance Arbitrary ProtoVersion where + arbitrary = ProtoVersion 1 <$> arbitrary <*> pure mempty +instance Arbitrary ProtoFeature where + arbitrary = arbitraryBoundedEnum + deriving via GenericArbitrary StoreText instance Arbitrary StoreText @@ -48,9 +55,6 @@ pure Trace{..} -deriving via GenericArbitrary BasicError - instance Arbitrary BasicError - instance Arbitrary ErrorInfo where arbitrary = do errorInfoLevel <- arbitrary @@ -95,13 +99,20 @@ instance Arbitrary (Some StoreRequest) where arbitrary = oneof - [ Some <$> (AddToStore <$> arbitrary <*> arbitrary <*> arbitrary <*> pure RepairMode_DontRepair) + [ Some <$> (AddToStore <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary) + , Some <$> (AddToStoreScanning <$> arbitrary <*> arbitrary <*> arbitrary) , Some <$> (AddTextToStore <$> arbitrary <*> arbitrary <*> pure RepairMode_DontRepair) , Some <$> (AddSignatures <$> arbitrary <*> arbitrary) , Some . AddIndirectRoot <$> arbitrary , Some . AddTempRoot <$> arbitrary , Some <$> (BuildPaths <$> arbitrary <*> arbitrary) - , Some <$> (BuildDerivation <$> arbitrary <*> arbitrary <*> arbitrary) + , do + path <- arbitrary + drv <- arbitrary + buildMode' <- arbitrary + -- Ensure store path name matches derivation name (helps with length issues) + let path' = path { storePathName = name drv } + pure $ Some (BuildDerivation path' drv buildMode') , Some . CollectGarbage <$> arbitrary , Some . EnsurePath <$> arbitrary , pure $ Some FindRoots @@ -118,6 +129,7 @@ , Some . QueryPathFromHashPart <$> arbitrary , Some . QueryMissing <$> arbitrary , pure $ Some OptimiseStore + , Some <$> (SubmitOutput <$> arbitrary <*> arbitrary) , pure $ Some SyncWithGC , Some <$> (VerifyStore <$> arbitrary <*> arbitrary) ] diff --git a/src/System/Nix/Store/Remote/Client.hs b/src/System/Nix/Store/Remote/Client.hs --- a/src/System/Nix/Store/Remote/Client.hs +++ b/src/System/Nix/Store/Remote/Client.hs @@ -1,6 +1,7 @@ module System.Nix.Store.Remote.Client ( addToStore , addToStoreNar + , addToStoreScanning , addTextToStore , addSignatures , addTempRoot @@ -23,6 +24,7 @@ , queryPathFromHashPart , queryMissing , optimiseStore + , submitOutput , syncWithGC , verifyStore , module System.Nix.Store.Remote.Client.Core @@ -38,44 +40,65 @@ import Data.Word (Word64) import System.Nix.Build (BuildMode, BuildResult) -import System.Nix.DerivedPath (DerivedPath) +import System.Nix.Derivation.Traditional qualified +import System.Nix.Derivation.ATerm qualified +import System.Nix.DerivedPath (DerivedPath, SingleDerivedPath) import System.Nix.Hash (HashAlgo(..)) import System.Nix.Nar (NarSource) +import System.Nix.OutputName (OutputName) import System.Nix.Signature (Signature) import System.Nix.StorePath (StorePath, StorePathHashPart, StorePathName) import System.Nix.StorePath.Metadata (Metadata) import System.Nix.Store.Remote.MonadStore import System.Nix.Store.Remote.Types.GC (GCOptions, GCResult, GCRoot) import System.Nix.Store.Remote.Types.CheckMode (CheckMode) +import System.Nix.Store.Remote.Types.ProtoVersion (ProtoFeature(..), hasFeature) import System.Nix.Store.Remote.Types.Query.Missing (Missing) import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..)) import System.Nix.Store.Remote.Types.StoreText (StoreText) import System.Nix.Store.Remote.Types.SubstituteMode (SubstituteMode) import System.Nix.Store.Remote.Client.Core -import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..)) +import System.Nix.ContentAddress (ContentAddressMethod) +import System.Nix.Store.Types (RepairMode(..)) -import qualified Control.Monad.IO.Class -import qualified Data.Attoparsec.Text -import qualified Data.Text.IO -import qualified System.Nix.Derivation -import qualified System.Nix.StorePath +import Control.Monad.IO.Class qualified +import Data.Attoparsec.Text qualified +import Data.Text.IO qualified +import System.Nix.Derivation qualified +import System.Nix.StorePath qualified -- | Add `NarSource` to the store addToStore :: MonadRemoteStore m => StorePathName -- ^ Name part of the newly created `StorePath` -> NarSource IO -- ^ Provide nar stream - -> FileIngestionMethod -- ^ Add target directory recursively - -> Some HashAlgo -- ^ - -> RepairMode -- ^ Only used by local store backend + -> ContentAddressMethod -- ^ Content addressing method + -> Some HashAlgo -- ^ Hashing algorithm + -> Set StorePath -- ^ References + -> RepairMode -- ^ Whether to overwrite an existing valid path, repairing corruption. + -- Sent to the daemon as part of the request since the 1.25 wire format. -> m StorePath -addToStore name source method hashAlgo repair = do - Control.Monad.when - (repair == RepairMode_DoRepair) - $ throwError RemoteStoreError_RapairNotSupportedByRemoteStore +addToStore name source method hashAlgo refs repair = do + setNarSource source + doReq (AddToStore name method hashAlgo refs repair) +-- | Add `NarSource` to the store, letting the daemon scan the +-- contents for references instead of declaring them. +-- +-- Only valid on connections where @add-to-store-scanning@ was +-- negotiated, i.e. inside a derivation build with the +-- @recursive-nix@ or @builder-rpc-v0@ system feature. +addToStoreScanning + :: MonadRemoteStore m + => StorePathName -- ^ Name part of the newly created `StorePath` + -> NarSource IO -- ^ Provide nar stream + -> ContentAddressMethod -- ^ Content addressing method + -> Some HashAlgo -- ^ Hashing algorithm + -> m StorePath +addToStoreScanning name source method hashAlgo = do + requireProtoFeature ProtoFeature_AddToStoreScanning setNarSource source - doReq (AddToStore name method hashAlgo repair) + doReq (AddToStoreScanning name method hashAlgo) addToStoreNar :: MonadRemoteStore m @@ -144,9 +167,24 @@ $ Data.Text.IO.readFile $ System.Nix.StorePath.storePathToFilePath sd sp case Data.Attoparsec.Text.parseOnly - (System.Nix.Derivation.parseDerivation sd) drvContents of + (System.Nix.Derivation.ATerm.parseTraditionalDerivation sd) drvContents of Left e -> throwError $ RemoteStoreError_DerivationParse e - Right drv -> doReq (BuildDerivation sp drv mode) + Right drv -> do + let name = System.Nix.StorePath.storePathName sp + outputs <- case + System.Nix.Derivation.toSpecificOutputs sd name $ + System.Nix.Derivation.Traditional.anonOutputs drv + of + Nothing -> throwError $ RemoteStoreError_DerivationParse "TODO get error" + Just os -> pure os + let drv' = System.Nix.Derivation.Traditional.withName name $ + drv + { System.Nix.Derivation.Traditional.anonOutputs = outputs + , System.Nix.Derivation.Traditional.anonInputs = + System.Nix.Derivation.Traditional.traditionalSrcs + (System.Nix.Derivation.Traditional.anonInputs drv) + } + doReq (BuildDerivation sp drv' mode) -- | Build paths if they are an actual derivations. -- @@ -266,10 +304,37 @@ => m () optimiseStore = (void . doReq) OptimiseStore +-- | Register a store object as an output of the currently running +-- derivation. +-- +-- Only valid on connections where @submit-output@ was negotiated, +-- i.e. inside a derivation build with the @builder-rpc-v0@ system +-- feature. +submitOutput + :: MonadRemoteStore m + => SingleDerivedPath + -> OutputName + -> m () +submitOutput path output = do + requireProtoFeature ProtoFeature_SubmitOutput + void $ doReq (SubmitOutput path output) + syncWithGC :: MonadRemoteStore m => m () syncWithGC = (void . doReq) SyncWithGC + +-- | Fail early with a clear error instead of letting the daemon +-- reject the opcode. +requireProtoFeature + :: MonadRemoteStore m + => ProtoFeature + -> m () +requireProtoFeature f = do + pv <- getProtoVersion + Control.Monad.when + (not $ hasFeature f pv) + $ throwError $ RemoteStoreError_ProtocolFeatureNotNegotiated f verifyStore :: MonadRemoteStore m diff --git a/src/System/Nix/Store/Remote/Client/Core.hs b/src/System/Nix/Store/Remote/Client/Core.hs --- a/src/System/Nix/Store/Remote/Client/Core.hs +++ b/src/System/Nix/Store/Remote/Client/Core.hs @@ -4,11 +4,14 @@ , doReq ) where +import Algebra.PartialOrd (leq) import Control.Monad (unless, when) import Control.Monad.Except (throwError) import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Bits (shiftR) import Data.ByteString (ByteString) import Data.DList (DList) +import Data.Set qualified import Data.Some (Some(Some)) import Data.Word (Word64) import Network.Socket (Socket) @@ -24,7 +27,9 @@ ( bool , int , mapErrorS + , protoFeatures , protoVersion + , validPathInfo , storeRequest , text , trustedFlag @@ -33,13 +38,13 @@ import System.Nix.Store.Remote.Types.Handshake (ClientHandshakeOutput(..)) import System.Nix.Store.Remote.Types.Logger (Logger) import System.Nix.Store.Remote.Types.NoReply (NoReply(..)) -import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..)) +import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..), minVersionNumber) import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..)) import System.Nix.Store.Remote.Types.StoreReply (StoreReply(..)) import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..)) -import qualified Data.ByteString -import qualified Network.Socket.ByteString +import Data.ByteString qualified +import Network.Socket.ByteString qualified type Run m a = m (Either RemoteStoreError a, DList Logger) @@ -55,28 +60,46 @@ -> m a doReq = \case x -> do + storeDir <- getStoreDir + pv <- getProtoVersion sockPutS (mapErrorS RemoteStoreError_SerializerRequest - storeRequest + (storeRequest storeDir pv) ) (Some x) case x of AddToStore {} -> do + ms <- takeNarSource + soc <- getStoreSocket + case ms of + Just (stream :: NarSource IO) -> + liftIO $ writeFramedNarSource stream soc + Nothing -> + throwError + RemoteStoreError_NoNarSourceProvided + processOutput + -- New protocol returns ValidPathInfo (path + metadata) + (path, _metadata) <- sockGetS + $ mapErrorS RemoteStoreError_SerializerGet + $ validPathInfo storeDir + pure path + AddToStoreScanning {} -> do ms <- takeNarSource + soc <- getStoreSocket case ms of - Just (stream :: NarSource IO) -> do - soc <- getStoreSocket - liftIO - $ stream - $ Network.Socket.ByteString.sendAll soc + Just (stream :: NarSource IO) -> + liftIO $ writeFramedNarSource stream soc Nothing -> throwError RemoteStoreError_NoNarSourceProvided processOutput - processReply + (path, _metadata) <- sockGetS + $ mapErrorS RemoteStoreError_SerializerGet + $ validPathInfo storeDir + pure path AddToStoreNar _ meta _ _ -> do let narBytes = maybe 0 id $ metadataNarBytes meta @@ -112,9 +135,12 @@ processReply where - processReply = sockGetS + processReply = do + storeDir <- getStoreDir + pv <- getProtoVersion + sockGetS (mapErrorS RemoteStoreError_SerializerReply - $ getReplyS @a + $ getReplyS @a storeDir pv ) copyToSink @@ -135,6 +161,29 @@ let nextRemainingBytes = remainingBytes - (fromIntegral . Data.ByteString.length) bytes copyToSink sink nextRemainingBytes soc +-- | Write a NarSource as framed data to a socket. +-- Each chunk of NAR data is prefixed with its length as a +-- little-endian u64, terminated by a zero-length frame. +writeFramedNarSource :: NarSource IO -> Socket -> IO () +writeFramedNarSource narSource sock = do + narSource sendChunk + sendWord64le sock 0 -- terminator + where + sendChunk :: ByteString -> IO () + sendChunk bs = do + let len = Data.ByteString.length bs + when (len > 0) $ do + sendWord64le sock (fromIntegral len) + Network.Socket.ByteString.sendAll sock bs + + sendWord64le :: Socket -> Word64 -> IO () + sendWord64le s w = + Network.Socket.ByteString.sendAll s + $ Data.ByteString.pack + [ fromIntegral (shiftR w (i * 8)) + | i <- [0..7] + ] + writeFramedSource :: forall m . ( MonadIO m @@ -185,45 +234,46 @@ daemonVersion <- sockGetS protoVersion - when (daemonVersion < ProtoVersion 1 10) + when (not (ProtoVersion 1 37 mempty `leq` daemonVersion)) $ throwError RemoteStoreError_ClientVersionTooOld pv <- getProtoVersion sockPutS protoVersion pv - let leastCommonVersion = min daemonVersion pv + let leastCommonVersion = minVersionNumber daemonVersion pv - when (leastCommonVersion >= ProtoVersion 1 14) - $ sockPutS int (0 :: Int) -- affinity, obsolete + -- Feature exchange (>= 1.38) + negotiatedFeatures <- if ProtoVersion 1 38 mempty `leq` leastCommonVersion + then do + sockPutS + (mapErrorS RemoteStoreError_SerializerPut protoFeatures) + (protoVersion_features pv) + daemonFeatures <- sockGetS + $ mapErrorS RemoteStoreError_SerializerGet protoFeatures + pure $ Data.Set.intersection daemonFeatures (protoVersion_features pv) + else pure mempty - when (leastCommonVersion >= ProtoVersion 1 11) $ do - sockPutS - (mapErrorS RemoteStoreError_SerializerPut bool) - False -- reserveSpace, obsolete + let leastCommonVersionWithFeatures = leastCommonVersion { protoVersion_features = negotiatedFeatures } - daemonNixVersion <- if leastCommonVersion >= ProtoVersion 1 33 - then do - -- If we were buffering I/O, we would flush the output here. - txtVer <- - sockGetS - $ mapErrorS - RemoteStoreError_SerializerGet - text - pure $ Just txtVer - else pure Nothing + setProtoVersion leastCommonVersionWithFeatures - remoteTrustsUs <- if leastCommonVersion >= ProtoVersion 1 35 - then do - sockGetS - $ mapErrorS RemoteStoreError_SerializerHandshake trustedFlag - else pure Nothing + -- postHandshake: affinity (obsolete), reserveSpace (obsolete) + sockPutS int (0 :: Int) -- affinity, obsolete + sockPutS (mapErrorS RemoteStoreError_SerializerPut bool) False -- reserveSpace, obsolete - setProtoVersion leastCommonVersion + -- If we were buffering I/O, we would flush the output here. + + daemonNixVersion <- Just <$> + sockGetS (mapErrorS RemoteStoreError_SerializerGet text) + + remoteTrustsUs <- + sockGetS (mapErrorS RemoteStoreError_SerializerHandshake trustedFlag) + processOutput pure ClientHandshakeOutput { clientHandshakeOutputNixVersion = daemonNixVersion , clientHandshakeOutputTrust = remoteTrustsUs - , clientHandshakeOutputLeastCommonVersion = leastCommonVersion + , clientHandshakeOutputLeastCommonVersion = leastCommonVersionWithFeatures , clientHandshakeOutputServerVersion = daemonVersion } diff --git a/src/System/Nix/Store/Remote/Logger.hs b/src/System/Nix/Store/Remote/Logger.hs --- a/src/System/Nix/Store/Remote/Logger.hs +++ b/src/System/Nix/Store/Remote/Logger.hs @@ -6,16 +6,16 @@ import Control.Monad.IO.Class (liftIO) import Data.ByteString (ByteString) import Data.Serialize (Result(..)) -import System.Nix.Store.Remote.Serializer (LoggerSError, logger, runSerialT) +import System.Nix.Store.Remote.Serializer (LoggerSError, logger, runExceptT) import System.Nix.Store.Remote.Socket (sockGet8) import System.Nix.Store.Remote.MonadStore (MonadRemoteStore, RemoteStoreError(..), appendLog, getDataSource, getDataSink, getStoreSocket, getProtoVersion) import System.Nix.Store.Remote.Types.Logger (Logger(..)) import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion) -import qualified Control.Monad -import qualified Data.Serialize.Get -import qualified Data.Serializer -import qualified Network.Socket.ByteString +import Control.Monad qualified +import Data.Serialize.Get qualified +import Data.Serializer qualified +import Network.Socket.ByteString qualified processOutput :: MonadRemoteStore m @@ -30,7 +30,7 @@ -> Result (Either LoggerSError Logger) decoder protoVersion = Data.Serialize.Get.runGetPartial - (runSerialT protoVersion $ Data.Serializer.getS logger) + (runExceptT $ Data.Serializer.getS $ logger protoVersion) go :: MonadRemoteStore m diff --git a/src/System/Nix/Store/Remote/MonadStore.hs b/src/System/Nix/Store/Remote/MonadStore.hs --- a/src/System/Nix/Store/Remote/MonadStore.hs +++ b/src/System/Nix/Store/Remote/MonadStore.hs @@ -29,11 +29,11 @@ import System.Nix.Nar (NarSource) import System.Nix.StorePath (HasStoreDir(..), StoreDir) import System.Nix.Store.Remote.Serializer (HandshakeSError, LoggerSError, RequestSError, ReplySError, SError) -import System.Nix.Store.Remote.Types.Logger (Logger, BasicError, ErrorInfo) -import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion) +import System.Nix.Store.Remote.Types.Logger (Logger, ErrorInfo) +import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoFeature, ProtoVersion) import System.Nix.Store.Remote.Types.StoreConfig (ProtoStoreConfig(..)) -import qualified Data.DList +import Data.DList qualified data RemoteStoreState = RemoteStoreState { remoteStoreStateConfig :: ProtoStoreConfig @@ -74,7 +74,7 @@ | RemoteStoreError_SerializerRequest RequestSError | RemoteStoreError_SerializerReply ReplySError | RemoteStoreError_IOException SomeException - | RemoteStoreError_LoggerError (Either BasicError ErrorInfo) + | RemoteStoreError_LoggerError ErrorInfo | RemoteStoreError_LoggerLeftovers String ByteString -- when there are bytes left over after incremental logger parser is done, (Done x leftover), first param is show x | RemoteStoreError_LoggerParserFail String ByteString -- when incremental parser returns ((Fail msg leftover) :: Result) | RemoteStoreError_NoDataSourceProvided -- remoteStoreStateMDataSource is required but it is Nothing @@ -85,6 +85,7 @@ | RemoteStoreError_NoDataSinkSizeProvided -- remoteStoreStateMDataSinkSize is required but it is Nothing | RemoteStoreError_NoNarSourceProvided | RemoteStoreError_OperationFailed + | RemoteStoreError_ProtocolFeatureNotNegotiated ProtoFeature | RemoteStoreError_ProtocolMismatch | RemoteStoreError_RapairNotSupportedByRemoteStore -- "repairing is not supported when building through the Nix daemon" | RemoteStoreError_WorkerMagic2Mismatch diff --git a/src/System/Nix/Store/Remote/Serializer.hs b/src/System/Nix/Store/Remote/Serializer.hs --- a/src/System/Nix/Store/Remote/Serializer.hs +++ b/src/System/Nix/Store/Remote/Serializer.hs @@ -9,1559 +9,1600 @@ ( -- * NixSerializer NixSerializer - , mapReaderS - , mapErrorS - -- * Errors - , SError(..) - -- ** Runners - , runSerialT - , runG - , runP - -- * Primitives - , int - , bool - , byteString - , enum - , text - , maybeText - -- * UTCTime - , time - -- * Combinators - , list - , set - , hashSet - , mapS - , vector - , json - -- * ProtoVersion - , protoVersion - -- * StorePath - , storePath - , maybePath - , storePathHashPart - , storePathName - -- * Metadata - , pathMetadata - -- * OutputName - , outputName - -- * Signatures - , signature - , narSignature - -- * Some HashAlgo - , someHashAlgo - -- * Digest - , digest - -- * DSum HashAlgo Digest - , namedDigest - -- * Derivation - , derivation - -- * Derivation - , derivedPath - -- * Build - , buildMode - -- * Logger - , LoggerSError(..) - , activityID - , maybeActivity - , activity - , activityResult - , field - , trace - , basicError - , errorInfo - , loggerOpCode - , logger - , verbosity - -- * Handshake - , HandshakeSError(..) - , workerMagic - , trustedFlag - -- * Worker protocol - , storeText - , workerOp - -- ** Request - , RequestSError(..) - , storeRequest - -- ** Reply - , ReplySError(..) - , opSuccess - , noop - -- *** Realisation - , derivationOutputTyped - , realisation - , realisationWithId - -- *** BuildResult - , buildResult - -- *** GCResult - , gcResult - -- *** GCResult - , gcRoot - -- *** Missing - , missing - -- *** Maybe (Metadata StorePath) - , maybePathMetadata - ) where - -import Control.Monad.Except (MonadError, throwError, ) -import Control.Monad.Reader (MonadReader) -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) -import Data.Hashable (Hashable) -import Data.HashSet (HashSet) -import Data.Map (Map) -import Data.Serializer -import Data.Set (Set) -import Data.Some (Some(Some)) -import Data.Text (Text) -import Data.Text.Lazy.Builder (Builder) -import Data.Time (NominalDiffTime, UTCTime) -import Data.Vector (Vector) -import Data.Word (Word8, Word32, Word64) -import GHC.Generics (Generic) -import System.Nix.Base (BaseEncoding(Base16, NixBase32)) -import System.Nix.Build (BuildMode, BuildResult(..)) -import System.Nix.ContentAddress (ContentAddress) -import System.Nix.Derivation (Derivation(..), DerivationOutput(..)) -import System.Nix.DerivedPath (DerivedPath(..), ParseOutputsError) -import System.Nix.Hash (HashAlgo(..)) -import System.Nix.JSON () -import System.Nix.OutputName (OutputName) -import System.Nix.Realisation (DerivationOutputError, Realisation(..), RealisationWithId(..)) -import System.Nix.Signature (Signature, NarSignature) -import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..)) -import System.Nix.StorePath (HasStoreDir(..), InvalidNameError, InvalidPathError, StorePath, StorePathHashPart, StorePathName) -import System.Nix.StorePath.Metadata (Metadata(..), StorePathTrust(..)) -import System.Nix.Store.Remote.Types - -import qualified Control.Monad -import qualified Control.Monad.Reader -import qualified Data.Aeson -import qualified Data.Attoparsec.Text -import qualified Data.Bifunctor -import qualified Data.Bits -import qualified Data.ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy -import qualified Data.Coerce -import qualified Data.HashSet -import qualified Data.Map.Strict -import qualified Data.Maybe -import qualified Data.Serialize.Get -import qualified Data.Serialize.Put -import qualified Data.Set -import qualified Data.Some -import qualified Data.Text -import qualified Data.Text.Encoding -import qualified Data.Text.Lazy -import qualified Data.Text.Lazy.Builder -import qualified Data.Time.Clock.POSIX -import qualified Data.Vector -import qualified System.Nix.Base -import qualified System.Nix.ContentAddress -import qualified System.Nix.DerivedPath -import qualified System.Nix.Hash -import qualified System.Nix.OutputName -import qualified System.Nix.Realisation -import qualified System.Nix.Signature -import qualified System.Nix.StorePath - --- | Transformer for @Serializer@ -newtype SerialT r e m a = SerialT - { _unSerialT :: ExceptT e (ReaderT r m) a } - deriving - ( Applicative - , Functor - , Monad - , MonadError e - , MonadReader r - , MonadFail - ) - -instance MonadTrans (SerialT r e) where - lift = SerialT . lift . lift - --- | Runner for @SerialT@ -runSerialT - :: Monad m - => r - -> SerialT r e m a - -> m (Either e a) -runSerialT r = - (`runReaderT` r) - . runExceptT - . _unSerialT - -mapErrorST - :: Functor m - => (e -> e') - -> SerialT r e m a - -> SerialT r e' m a -mapErrorST f = - SerialT - . withExceptT f - . _unSerialT - -mapErrorS - :: (e -> e') - -> NixSerializer r e a - -> NixSerializer r e' a -mapErrorS f s = Serializer - { getS = mapErrorST f $ getS s - , putS = mapErrorST f . putS s - } - -mapReaderST - :: Functor m - => (r' -> r) - -> SerialT r e m a - -> SerialT r' e m a -mapReaderST f = - SerialT - . (mapExceptT . withReaderT) f - . _unSerialT - -mapReaderS - :: (r' -> r) - -> NixSerializer r e a - -> NixSerializer r' e a -mapReaderS f s = Serializer - { getS = mapReaderST f $ getS s - , putS = mapReaderST f . putS s - } - --- * NixSerializer - -type NixSerializer r e = Serializer (SerialT r e) - --- * Errors - -data SError - = SError - | SError_BadPadding - { badPaddingStr :: ByteString - , badPaddingLen :: Int - , badPaddingPads :: [Word8] - } - | SError_ContentAddress String - | SError_DerivedPath ParseOutputsError - | SError_DerivationOutput DerivationOutputError - | SError_Digest String - | SError_EnumOutOfMinBound Int - | SError_EnumOutOfMaxBound Int - | SError_HashAlgo String - | SError_IllegalBool Word64 - | SError_InvalidNixBase32 - | SError_JSONDecoding String - | SError_NarHashMustBeSHA256 - | SError_NotYetImplemented String (ForPV ProtoVersion) - | SError_Name InvalidNameError - | SError_Path InvalidPathError - | SError_Signature String - deriving (Eq, Ord, Generic, Show) - -data ForPV a - = ForPV_Newer a - | ForPV_Older a - deriving (Eq, Ord, Generic, Show) - --- ** Runners - -runG - :: NixSerializer r e a - -> r - -> ByteString - -> Either (GetSerializerError e) a -runG serializer r = - transformGetError - . runGetS - serializer - (runSerialT r) - -runP - :: NixSerializer r e a - -> r - -> a - -> Either e ByteString -runP serializer r = - transformPutError - . runPutS - serializer - (runSerialT r) - --- * Primitives - -int :: Integral a => NixSerializer r e a -int = Serializer - { getS = fromIntegral <$> lift Data.Serialize.Get.getWord64le - , putS = lift . Data.Serialize.Put.putWord64le . fromIntegral - } - -bool :: NixSerializer r SError Bool -bool = Serializer - { getS = getS (int @Word64) >>= \case - 0 -> pure False - 1 -> pure True - x -> throwError $ SError_IllegalBool x - , putS = \case - False -> putS (int @Word8) 0 - True -> putS (int @Word8) 1 - } - -byteString :: NixSerializer r SError ByteString -byteString = Serializer - { getS = do - len <- getS int - st <- lift $ Data.Serialize.Get.getByteString len - Control.Monad.when (len `mod` 8 /= 0) $ do - pads <- unpad $ fromIntegral $ 8 - (len `mod` 8) - Control.Monad.unless - (all (== 0) pads) - $ throwError - $ SError_BadPadding st len pads - pure st - , putS = \x -> do - let len = Data.ByteString.length x - putS int len - lift $ Data.Serialize.Put.putByteString x - Control.Monad.when - (len `mod` 8 /= 0) - $ pad $ 8 - (len `mod` 8) - } - where - unpad count = - Control.Monad.replicateM - count - (lift Data.Serialize.Get.getWord8) - pad count = - Control.Monad.replicateM_ - count - (lift $ Data.Serialize.Put.putWord8 0) - --- | Utility toEnum version checking bounds using Bounded class -toEnumCheckBoundsM - :: forall a m - . ( Bounded a - , Enum a - , MonadError SError m - ) - => Int - -> m a -toEnumCheckBoundsM = \case - x | x < fromEnum (minBound @a) -> throwError $ SError_EnumOutOfMinBound x - x | x > fromEnum (maxBound @a) -> throwError $ SError_EnumOutOfMaxBound x - x | otherwise -> pure $ toEnum x - -enum - :: ( Bounded a - , Enum a - ) - => NixSerializer r SError a -enum = Serializer - { getS = getS int >>= toEnumCheckBoundsM - , putS = putS int . fromEnum - } - -text :: NixSerializer r SError Text -text = mapIsoSerializer - Data.Text.Encoding.decodeUtf8 - Data.Text.Encoding.encodeUtf8 - byteString - --- TODO Parser Builder -_textBuilder :: NixSerializer r SError Builder -_textBuilder = Serializer - { getS = Data.Text.Lazy.Builder.fromText <$> getS text - , putS = putS text . Data.Text.Lazy.toStrict . Data.Text.Lazy.Builder.toLazyText - } - -maybeText :: NixSerializer r SError (Maybe Text) -maybeText = mapIsoSerializer - (\case - t | Data.Text.null t -> Nothing - t | otherwise -> Just t - ) - (Data.Maybe.fromMaybe mempty) - text - --- * UTCTime - -time :: NixSerializer r e UTCTime -time = Serializer - { getS = - Data.Time.Clock.POSIX.posixSecondsToUTCTime - . toPicoSeconds - <$> getS int - , putS = - putS int - . fromPicoSeconds - . Data.Time.Clock.POSIX.utcTimeToPOSIXSeconds - } - where - -- fancy (*10^12), from Int to Uni to Pico(seconds) - toPicoSeconds :: Int -> NominalDiffTime - toPicoSeconds n = realToFrac (toEnum n :: Uni) - - -- fancy (`div`10^12), from Pico to Uni to Int - fromPicoSeconds :: NominalDiffTime -> Int - fromPicoSeconds = (fromEnum :: Uni -> Int) . realToFrac - --- * Combinators - -list - :: NixSerializer r e a - -> NixSerializer r e [a] -list s = Serializer - { getS = do - count <- getS int - Control.Monad.replicateM count (getS s) - , putS = \xs -> do - putS int (length xs) - mapM_ (putS s) xs - } - -set - :: Ord a - => NixSerializer r e a - -> NixSerializer r e (Set a) -set = - mapIsoSerializer - Data.Set.fromList - Data.Set.toList - . list - -hashSet - :: ( Eq a - , Hashable a - ) - => NixSerializer r e a - -> NixSerializer r e (HashSet a) -hashSet = - mapIsoSerializer - Data.HashSet.fromList - Data.HashSet.toList - . list - -mapS - :: Ord k - => NixSerializer r e k - -> NixSerializer r e v - -> NixSerializer r e (Map k v) -mapS k v = - mapIsoSerializer - Data.Map.Strict.fromList - Data.Map.Strict.toList - $ list - $ tup k v - -vector - :: Ord a - => NixSerializer r e a - -> NixSerializer r e (Vector a) -vector = - mapIsoSerializer - Data.Vector.fromList - 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 --- protoVersion_minor & 0x00FF -protoVersion :: NixSerializer r e ProtoVersion -protoVersion = Serializer - { getS = do - v <- getS (int @Word32) - pure ProtoVersion - { protoVersion_major = fromIntegral $ Data.Bits.shiftR v 8 - , protoVersion_minor = fromIntegral $ v Data.Bits..&. 0x00FF - } - , putS = \p -> - putS (int @Word32) - $ ((Data.Bits.shiftL (fromIntegral $ protoVersion_major p :: Word32) 8) - Data.Bits..|. fromIntegral (protoVersion_minor p)) - } - --- * StorePath - -storePath :: HasStoreDir r => NixSerializer r SError StorePath -storePath = Serializer - { getS = do - sd <- Control.Monad.Reader.asks hasStoreDir - System.Nix.StorePath.parsePath sd <$> getS byteString - >>= - either - (throwError . SError_Path) - pure - , putS = \p -> do - sd <- Control.Monad.Reader.asks hasStoreDir - putS - byteString - $ System.Nix.StorePath.storePathToRawFilePath sd p - } - -maybePath - :: HasStoreDir r - => NixSerializer r SError (Maybe StorePath) -maybePath = Serializer - { getS = do - getS maybeText >>= \case - Nothing -> pure Nothing - Just t -> do - sd <- Control.Monad.Reader.asks hasStoreDir - either - (throwError . SError_Path) - (pure . pure) - $ System.Nix.StorePath.parsePathFromText sd t - - , putS = \case - Nothing -> putS maybeText Nothing - Just p -> do - sd <- Control.Monad.Reader.asks hasStoreDir - putS text $ System.Nix.StorePath.storePathToText sd p - } - -storePathHashPart :: NixSerializer r SError StorePathHashPart -storePathHashPart = - mapIsoSerializer - System.Nix.StorePath.unsafeMakeStorePathHashPart - System.Nix.StorePath.unStorePathHashPart - $ mapPrismSerializer - (Data.Bifunctor.first (pure SError_InvalidNixBase32) - . System.Nix.Base.decodeWith NixBase32) - (System.Nix.Base.encodeWith NixBase32) - text - -storePathName :: NixSerializer r SError StorePathName -storePathName = - mapPrismSerializer - (Data.Bifunctor.first SError_Name - . System.Nix.StorePath.mkStorePathName) - System.Nix.StorePath.unStorePathName - text - -pathMetadata - :: HasStoreDir r - => NixSerializer r SError (Metadata StorePath) -pathMetadata = Serializer - { getS = do - metadataDeriverPath <- getS maybePath - - digest' <- getS $ digest Base16 - let metadataNarHash = System.Nix.Hash.HashAlgo_SHA256 :=> digest' - - metadataReferences <- getS $ hashSet storePath - metadataRegistrationTime <- getS time - metadataNarBytes <- - (\case - 0 -> Nothing - size -> Just size - ) <$> getS int - metadataTrust <- getS storePathTrust - - metadataSigs <- getS $ set narSignature - metadataContentAddress <- getS maybeContentAddress - - pure $ Metadata{..} - - , putS = \Metadata{..} -> do - putS maybePath metadataDeriverPath - - let putNarHash - :: DSum HashAlgo Digest - -> SerialT r SError PutM () - putNarHash = \case - System.Nix.Hash.HashAlgo_SHA256 :=> d - -> putS (digest @SHA256 Base16) d - _ -> throwError SError_NarHashMustBeSHA256 - - putNarHash metadataNarHash - - putS (hashSet storePath) metadataReferences - putS time metadataRegistrationTime - putS int $ Data.Maybe.fromMaybe 0 metadataNarBytes - putS storePathTrust metadataTrust - putS (set narSignature) metadataSigs - putS maybeContentAddress metadataContentAddress - } - where - maybeContentAddress - :: NixSerializer r SError (Maybe ContentAddress) - maybeContentAddress = - mapPrismSerializer - (maybe - (pure Nothing) - $ Data.Bifunctor.bimap - SError_ContentAddress - Just - . System.Nix.ContentAddress.parseContentAddress - ) - (fmap System.Nix.ContentAddress.buildContentAddress) - maybeText - - storePathTrust - :: NixSerializer r SError StorePathTrust - storePathTrust = - mapIsoSerializer - (\case False -> BuiltElsewhere; True -> BuiltLocally) - (\case BuiltElsewhere -> False; BuiltLocally -> True) - bool - --- * OutputName - -outputName :: NixSerializer r SError OutputName -outputName = - mapPrismSerializer - (Data.Bifunctor.first SError_Name - . System.Nix.OutputName.mkOutputName) - System.Nix.OutputName.unOutputName - text - --- * Signatures - -signature - :: NixSerializer r SError Signature -signature = - mapPrismSerializer - (Data.Bifunctor.first SError_Signature - . Data.Attoparsec.Text.parseOnly - System.Nix.Signature.signatureParser) - (System.Nix.Signature.signatureToText) - text - -narSignature - :: NixSerializer r SError NarSignature -narSignature = - mapPrismSerializer - (Data.Bifunctor.first SError_Signature - . Data.Attoparsec.Text.parseOnly - System.Nix.Signature.narSignatureParser) - (System.Nix.Signature.narSignatureToText) - text - --- * Some HashAlgo - -someHashAlgo :: NixSerializer r SError (Some HashAlgo) -someHashAlgo = - mapPrismSerializer - (Data.Bifunctor.first SError_HashAlgo - . System.Nix.Hash.textToAlgo) - (Data.Some.foldSome System.Nix.Hash.algoToText) - text - --- * Digest - -digest - :: forall a r - . HashAlgorithm a - => BaseEncoding - -> NixSerializer r SError (Digest a) -digest base = - mapIsoSerializer - Data.Coerce.coerce - Data.Coerce.coerce - $ mapPrismSerializer - (Data.Bifunctor.first SError_Digest - . System.Nix.Hash.decodeDigestWith @a base) - (System.Nix.Hash.encodeDigestWith base) - $ text - --- * DSum HashAlgo Digest - -namedDigest :: NixSerializer r SError (DSum HashAlgo Digest) -namedDigest = Serializer - { getS = do - sriHash <- getS text - let (sriName, _h) = Data.Text.breakOn (Data.Text.singleton '-') sriHash - -- bit hacky since mkNamedDigest does the check - -- that the expected matches but we don't know - -- what we expect here (i.e. handle each HashAlgo) - case System.Nix.Hash.mkNamedDigest sriName sriHash of - Left e -> throwError $ SError_Digest e - Right x -> pure x - -- TODO: we also lack a builder for SRI hashes - -- , putS = putS textBuilder . System.Nix.Hash.algoDigestBuilder - , putS = \(algo :=> d) -> do - putS text - $ System.Nix.Hash.algoToText algo - <> (Data.Text.singleton '-') - <> System.Nix.Hash.encodeDigestWith NixBase32 d - } - -derivationOutput - :: HasStoreDir r - => NixSerializer r SError (DerivationOutput StorePath Text) -derivationOutput = Serializer - { getS = do - path <- getS storePath - hashAlgo <- getS text - hash <- getS text - pure DerivationOutput{..} - , putS = \DerivationOutput{..} -> do - putS storePath path - putS text hashAlgo - putS text hash - } - --- * Derivation - -derivation - :: HasStoreDir r - => NixSerializer r SError (Derivation StorePath Text) -derivation = Serializer - { getS = do - outputs <- getS (mapS text derivationOutput) - -- Our type is Derivation, but in Nix - -- the type sent over the wire is BasicDerivation - -- which omits inputDrvs - inputDrvs <- pure mempty - inputSrcs <- getS (set storePath) - - platform <- getS text - builder <- getS text - args <- getS (vector text) - env <- getS (mapS text text) - pure Derivation{..} - , putS = \Derivation{..} -> do - putS (mapS text derivationOutput) outputs - putS (set storePath) inputSrcs - putS text platform - putS text builder - putS (vector text) args - putS (mapS text text) env - } - --- * DerivedPath - -derivedPathNew - :: HasStoreDir r - => NixSerializer r SError DerivedPath -derivedPathNew = Serializer - { getS = do - root <- Control.Monad.Reader.asks hasStoreDir - p <- getS text - case System.Nix.DerivedPath.parseDerivedPath root p of - Left err -> throwError $ SError_DerivedPath err - Right x -> pure x - , putS = \d -> do - root <- Control.Monad.Reader.asks hasStoreDir - putS text (System.Nix.DerivedPath.derivedPathToText root d) - } - -derivedPath - :: ( HasProtoVersion r - , HasStoreDir r - ) - => NixSerializer r SError DerivedPath -derivedPath = Serializer - { getS = do - pv <- Control.Monad.Reader.asks hasProtoVersion - if pv < ProtoVersion 1 30 - then DerivedPath_Opaque <$> getS storePath - else getS derivedPathNew - , putS = \d -> do - pv <- Control.Monad.Reader.asks hasProtoVersion - if pv < ProtoVersion 1 30 - then case d of - DerivedPath_Opaque p -> putS storePath p - _ -> throwError - $ SError_NotYetImplemented - "DerivedPath_Built" - (ForPV_Older pv) - else putS derivedPathNew d - } - --- * Build - -buildMode :: NixSerializer r SError BuildMode -buildMode = enum - --- * Logger - -data LoggerSError - = LoggerSError_Prim SError - | LoggerSError_InvalidOpCode Word64 - | LoggerSError_TooOldForErrorInfo - | LoggerSError_TooNewForBasicError - | LoggerSError_UnknownLogFieldType Word8 - deriving (Eq, Ord, Generic, Show) - -mapPrimE - :: Functor m - => SerialT r SError m a - -> SerialT r LoggerSError m a -mapPrimE = mapErrorST LoggerSError_Prim - -maybeActivity :: NixSerializer r LoggerSError (Maybe Activity) -maybeActivity = Serializer - { getS = getS (int @Int) >>= \case - 0 -> pure Nothing - x -> mapPrimE $ toEnumCheckBoundsM (x - 100) >>= pure . Just - , putS = \case - Nothing -> putS (int @Int) 0 - Just act -> putS activity act - } - -activity :: NixSerializer r LoggerSError Activity -activity = Serializer - { getS = mapPrimE $ getS int >>= toEnumCheckBoundsM . (+(-100)) - , putS = putS int . (+100) . fromEnum - } - -activityID :: NixSerializer r LoggerSError ActivityID -activityID = mapIsoSerializer ActivityID unActivityID int - -activityResult :: NixSerializer r LoggerSError ActivityResult -activityResult = Serializer - { getS = mapPrimE $ getS int >>= toEnumCheckBoundsM . (+(-100)) - , putS = putS int . (+100) . fromEnum - } - -field :: NixSerializer r LoggerSError Field -field = Serializer - { getS = getS (int @Word8) >>= \case - 0 -> Field_LogInt <$> getS int - 1 -> Field_LogStr <$> mapPrimE (getS text) - x -> throwError $ LoggerSError_UnknownLogFieldType x - , putS = \case - Field_LogInt x -> putS int (0 :: Word8) >> putS int x - Field_LogStr x -> putS int (1 :: Word8) >> mapPrimE (putS text x) - } - -trace :: NixSerializer r LoggerSError Trace -trace = Serializer - { getS = do - tracePosition <- (\case 0 -> Nothing; x -> Just x) <$> getS (int @Int) - traceHint <- mapPrimE $ getS text - pure Trace{..} - , putS = \Trace{..} -> do - putS int $ Data.Maybe.fromMaybe 0 tracePosition - mapPrimE $ putS text traceHint - } - -basicError :: NixSerializer r LoggerSError BasicError -basicError = Serializer - { getS = do - basicErrorMessage <- mapPrimE $ getS text - basicErrorExitStatus <- getS int - pure BasicError{..} - - , putS = \BasicError{..} -> do - mapPrimE $ putS text basicErrorMessage - putS int basicErrorExitStatus - } - -errorInfo :: NixSerializer r LoggerSError ErrorInfo -errorInfo = Serializer - { getS = do - etyp <- mapPrimE $ getS text - Control.Monad.unless (etyp == Data.Text.pack "Error") - $ fail - $ "get ErrorInfo: received unknown error type" ++ show etyp - errorInfoLevel <- getS verbosity - _name <- mapPrimE $ getS text -- removed error name - errorInfoMessage <- mapPrimE $ getS text - errorInfoPosition <- (\case 0 -> Nothing; x -> Just x) <$> getS int - errorInfoTraces <- getS (list trace) - pure ErrorInfo{..} - - , putS = \ErrorInfo{..} -> do - mapPrimE $ do - putS text $ Data.Text.pack "Error" - putS verbosity errorInfoLevel - mapPrimE $ do - putS text $ Data.Text.pack "Error" -- removed error name - putS text errorInfoMessage - putS int $ Data.Maybe.fromMaybe 0 errorInfoPosition - putS (list trace) errorInfoTraces - } - -loggerOpCode :: NixSerializer r LoggerSError LoggerOpCode -loggerOpCode = Serializer - { getS = do - c <- getS int - either - (pure $ throwError (LoggerSError_InvalidOpCode c)) - pure - $ word64ToLoggerOpCode c - , putS = putS int . loggerOpCodeToWord64 - } - -logger - :: HasProtoVersion r - => NixSerializer r LoggerSError Logger -logger = Serializer - { getS = getS loggerOpCode >>= \case - LoggerOpCode_Next -> - mapPrimE $ - Logger_Next <$> getS text - - LoggerOpCode_Read -> - Logger_Read <$> getS int - - LoggerOpCode_Write -> - mapPrimE $ - Logger_Write <$> getS byteString - - LoggerOpCode_Last -> - pure Logger_Last - - LoggerOpCode_Error -> do - pv <- Control.Monad.Reader.asks hasProtoVersion - Logger_Error <$> - if protoVersion_minor pv >= 26 - then Right <$> getS errorInfo - else Left <$> getS basicError - - LoggerOpCode_StartActivity -> do - startActivityID <- getS activityID - startActivityVerbosity <- getS verbosity - startActivityType <- getS maybeActivity - startActivityString <- mapPrimE $ getS byteString - startActivityFields <- getS (list field) - startActivityParentID <- getS activityID - pure Logger_StartActivity{..} - - LoggerOpCode_StopActivity -> do - stopActivityID <- getS activityID - pure Logger_StopActivity{..} - - LoggerOpCode_Result -> do - resultActivityID <- getS activityID - resultType <- getS activityResult - resultFields <- getS (list field) - pure Logger_Result {..} - - , putS = \case - Logger_Next s -> do - putS loggerOpCode LoggerOpCode_Next - mapPrimE $ putS text s - - Logger_Read i -> do - putS loggerOpCode LoggerOpCode_Read - putS int i - - Logger_Write s -> do - putS loggerOpCode LoggerOpCode_Write - mapPrimE $ putS byteString s - - Logger_Last -> - putS loggerOpCode LoggerOpCode_Last - - Logger_Error basicOrInfo -> do - putS loggerOpCode LoggerOpCode_Error - - minor <- protoVersion_minor <$> Control.Monad.Reader.asks hasProtoVersion - - case basicOrInfo of - Left _ | minor >= 26 -> throwError $ LoggerSError_TooNewForBasicError - Left e | otherwise -> putS basicError e - Right _ | minor < 26 -> throwError $ LoggerSError_TooOldForErrorInfo - Right e -> putS errorInfo e - - Logger_StartActivity{..} -> do - putS loggerOpCode LoggerOpCode_StartActivity - putS activityID startActivityID - putS verbosity startActivityVerbosity - putS maybeActivity startActivityType - mapPrimE $ - putS byteString startActivityString - putS (list field) startActivityFields - putS activityID startActivityParentID - - Logger_StopActivity{..} -> do - putS loggerOpCode LoggerOpCode_StopActivity - putS activityID stopActivityID - - Logger_Result{..} -> do - putS loggerOpCode LoggerOpCode_Result - putS activityID resultActivityID - putS activityResult resultType - putS (list field) resultFields - } - -verbosity :: NixSerializer r LoggerSError Verbosity -verbosity = Serializer - { getS = mapPrimE $ getS enum - , putS = mapPrimE . putS enum - } - --- * Handshake - -data HandshakeSError - = HandshakeSError_InvalidWorkerMagic Word64 - | HandshakeSError_InvalidTrustedFlag Word8 - deriving (Eq, Ord, Generic, Show) - -workerMagic :: NixSerializer r HandshakeSError WorkerMagic -workerMagic = Serializer - { getS = do - c <- getS int - either - (pure $ throwError (HandshakeSError_InvalidWorkerMagic c)) - pure - $ word64ToWorkerMagic c - , putS = putS int . workerMagicToWord64 - } - -trustedFlag :: NixSerializer r HandshakeSError (Maybe TrustedFlag) -trustedFlag = Serializer - { getS = do - n :: Word8 <- getS int - case n of - 0 -> return $ Nothing - 1 -> return $ Just TrustedFlag_Trusted - 2 -> return $ Just TrustedFlag_NotTrusted - _ -> throwError (HandshakeSError_InvalidTrustedFlag n) - , putS = \n -> putS int $ case n of - Nothing -> 0 :: Word8 - Just TrustedFlag_Trusted -> 1 - Just TrustedFlag_NotTrusted -> 2 - } - --- * Worker protocol - -storeText :: NixSerializer r SError StoreText -storeText = Serializer - { getS = do - storeTextName <- getS storePathName - storeTextText <- getS text - pure StoreText{..} - , putS = \StoreText{..} -> do - putS storePathName storeTextName - putS text storeTextText - } - -workerOp :: NixSerializer r SError WorkerOp -workerOp = enum - --- * Request - -data RequestSError - = RequestSError_NotYetImplemented WorkerOp - | RequestSError_ReservedOp WorkerOp - | RequestSError_PrimGet SError - | RequestSError_PrimPut SError - | RequestSError_PrimWorkerOp SError - deriving (Eq, Ord, Generic, Show) - -storeRequest - :: ( HasProtoVersion r - , HasStoreDir r - ) - => NixSerializer r RequestSError (Some StoreRequest) -storeRequest = Serializer - { getS = mapErrorST RequestSError_PrimWorkerOp (getS workerOp) >>= \case - WorkerOp_AddToStore -> mapGetE $ do - pathName <- getS storePathName - _fixed <- getS bool -- obsolete - recursive <- getS enum - hashAlgo <- getS someHashAlgo - - -- not supported by ProtoVersion < 1.25 - let repair = RepairMode_DontRepair - - pure $ Some (AddToStore pathName recursive hashAlgo repair) - - WorkerOp_AddToStoreNar -> mapGetE $ do - storePath' <- getS storePath - metadata <- getS pathMetadata - repair <- getS bool - let repairMode = if repair then RepairMode_DoRepair else RepairMode_DontRepair - dontCheckSigs <- getS bool - let checkSigs = if dontCheckSigs then CheckMode_DontCheck else CheckMode_DoCheck - - pure $ Some (AddToStoreNar storePath' metadata repairMode checkSigs) - - WorkerOp_AddTextToStore -> mapGetE $ do - txt <- getS storeText - paths <- getS (hashSet storePath) - let repair = RepairMode_DontRepair - pure $ Some (AddTextToStore txt paths repair) - - WorkerOp_AddSignatures -> mapGetE $ do - path <- getS storePath - signatures <- getS (set signature) - pure $ Some (AddSignatures path signatures) - - WorkerOp_AddIndirectRoot -> mapGetE $ do - Some . AddIndirectRoot <$> getS storePath - - WorkerOp_AddTempRoot -> mapGetE $ do - Some . AddTempRoot <$> getS storePath - - WorkerOp_BuildPaths -> mapGetE $ do - derived <- getS (set derivedPath) - buildMode' <- getS buildMode - pure $ Some (BuildPaths derived buildMode') - - WorkerOp_BuildDerivation -> mapGetE $ do - path <- getS storePath - drv <- getS derivation - buildMode' <- getS buildMode - pure $ Some (BuildDerivation path drv buildMode') - - WorkerOp_CollectGarbage -> mapGetE $ do - gcOptionsOperation <- getS enum - gcOptionsPathsToDelete <- getS (hashSet storePath) - gcOptionsIgnoreLiveness <- getS bool - gcOptionsMaxFreed <- getS int - -- obsolete fields - Control.Monad.forM_ [0..(2 :: Word8)] - $ pure $ getS (int @Word8) - pure $ Some (CollectGarbage GCOptions{..}) - - WorkerOp_EnsurePath -> mapGetE $ do - Some . EnsurePath <$> getS storePath - - WorkerOp_FindRoots -> mapGetE $ do - pure $ Some FindRoots - - WorkerOp_IsValidPath -> mapGetE $ do - Some . IsValidPath <$> getS storePath - - WorkerOp_NarFromPath -> mapGetE $ do - Some . NarFromPath <$> getS storePath - - WorkerOp_QueryValidPaths -> mapGetE $ do - paths <- getS (hashSet storePath) - substituteMode <- getS enum - pure $ Some (QueryValidPaths paths substituteMode) - - WorkerOp_QueryAllValidPaths -> mapGetE $ do - pure $ Some QueryAllValidPaths - - WorkerOp_QuerySubstitutablePaths -> mapGetE $ do - Some . QuerySubstitutablePaths <$> getS (hashSet storePath) - - WorkerOp_QueryPathInfo -> mapGetE $ do - Some . QueryPathInfo <$> getS storePath - - WorkerOp_QueryReferrers -> mapGetE $ do - Some . QueryReferrers <$> getS storePath - - WorkerOp_QueryValidDerivers -> mapGetE $ do - Some . QueryValidDerivers <$> getS storePath - - WorkerOp_QueryDerivationOutputs -> mapGetE $ do - Some . QueryDerivationOutputs <$> getS storePath - - WorkerOp_QueryDerivationOutputNames -> mapGetE $ do - Some . QueryDerivationOutputNames <$> getS storePath - - WorkerOp_QueryPathFromHashPart -> mapGetE $ do - Some . QueryPathFromHashPart <$> getS storePathHashPart - - WorkerOp_QueryMissing -> mapGetE $ do - Some . QueryMissing <$> getS (set derivedPath) - - WorkerOp_OptimiseStore -> mapGetE $ do - pure $ Some OptimiseStore - - WorkerOp_SyncWithGC -> mapGetE $ do - pure $ Some SyncWithGC - - WorkerOp_VerifyStore -> mapGetE $ do - checkMode <- getS enum - repairMode <- getS enum - - pure $ Some (VerifyStore checkMode repairMode) - - w@WorkerOp_Reserved_0__ -> reserved w - w@WorkerOp_Reserved_2__ -> reserved w - w@WorkerOp_Reserved_15__ -> reserved w - w@WorkerOp_Reserved_17__ -> reserved w - - w@WorkerOp_AddBuildLog -> notYet w - w@WorkerOp_AddMultipleToStore -> notYet w - w@WorkerOp_BuildPathsWithResults -> notYet w - w@WorkerOp_ClearFailedPaths -> notYet w - w@WorkerOp_ExportPath -> notYet w - w@WorkerOp_HasSubstitutes -> notYet w - w@WorkerOp_ImportPaths -> notYet w - w@WorkerOp_QueryDerivationOutputMap -> notYet w - w@WorkerOp_QueryDeriver -> notYet w - w@WorkerOp_QueryFailedPaths -> notYet w - w@WorkerOp_QueryPathHash -> notYet w - w@WorkerOp_QueryRealisation -> notYet w - w@WorkerOp_QuerySubstitutablePathInfo -> notYet w - w@WorkerOp_QuerySubstitutablePathInfos -> notYet w - w@WorkerOp_QueryReferences -> notYet w - w@WorkerOp_RegisterDrvOutput -> notYet w - w@WorkerOp_SetOptions -> notYet w - - , putS = \case - Some (AddToStore pathName recursive hashAlgo _repair) -> mapPutE $ do - putS workerOp WorkerOp_AddToStore - - putS storePathName pathName - -- obsolete fixed - putS bool - $ not - $ hashAlgo == Some HashAlgo_SHA256 - && (recursive == FileIngestionMethod_FileRecursive) - - putS bool (recursive == FileIngestionMethod_FileRecursive) - putS someHashAlgo hashAlgo - - Some (AddToStoreNar storePath' metadata repair checkSigs) -> mapPutE $ do - putS workerOp WorkerOp_AddToStoreNar - - putS storePath storePath' - putS pathMetadata metadata - putS bool $ repair == RepairMode_DoRepair - putS bool $ checkSigs == CheckMode_DontCheck - - Some (AddTextToStore txt paths _repair) -> mapPutE $ do - putS workerOp WorkerOp_AddTextToStore - - putS storeText txt - putS (hashSet storePath) paths - - Some (AddSignatures path signatures) -> mapPutE $ do - putS workerOp WorkerOp_AddSignatures - - putS storePath path - putS (set signature) signatures - - Some (AddIndirectRoot path) -> mapPutE $ do - putS workerOp WorkerOp_AddIndirectRoot - putS storePath path - - Some (AddTempRoot path) -> mapPutE $ do - putS workerOp WorkerOp_AddTempRoot - putS storePath path - - Some (BuildPaths derived buildMode') -> mapPutE $ do - putS workerOp WorkerOp_BuildPaths - - putS (set derivedPath) derived - putS buildMode buildMode' - - Some (BuildDerivation path drv buildMode') -> mapPutE $ do - putS workerOp WorkerOp_BuildDerivation - - putS storePath path - putS derivation drv - putS buildMode buildMode' - - Some (CollectGarbage GCOptions{..}) -> mapPutE $ do - putS workerOp WorkerOp_CollectGarbage - - putS enum gcOptionsOperation - putS (hashSet storePath) gcOptionsPathsToDelete - putS bool gcOptionsIgnoreLiveness - putS int gcOptionsMaxFreed - -- obsolete fields - Control.Monad.forM_ [0..(2 :: Word8)] - $ pure $ putS int (0 :: Word8) - - Some (EnsurePath path) -> mapPutE $ do - putS workerOp WorkerOp_EnsurePath - putS storePath path - - Some FindRoots -> mapPutE $ do - putS workerOp WorkerOp_FindRoots - - Some (IsValidPath path) -> mapPutE $ do - putS workerOp WorkerOp_IsValidPath - putS storePath path - - Some (NarFromPath path) -> mapPutE $ do - putS workerOp WorkerOp_NarFromPath - putS storePath path - - Some (QueryValidPaths paths substituteMode) -> mapPutE $ do - putS workerOp WorkerOp_QueryValidPaths - - putS (hashSet storePath) paths - putS enum substituteMode - - Some QueryAllValidPaths -> mapPutE $ do - putS workerOp WorkerOp_QueryAllValidPaths - - Some (QuerySubstitutablePaths paths) -> mapPutE $ do - putS workerOp WorkerOp_QuerySubstitutablePaths - putS (hashSet storePath) paths - - Some (QueryPathInfo path) -> mapPutE $ do - putS workerOp WorkerOp_QueryPathInfo - putS storePath path - - Some (QueryReferrers path) -> mapPutE $ do - putS workerOp WorkerOp_QueryReferrers - putS storePath path - - Some (QueryValidDerivers path) -> mapPutE $ do - putS workerOp WorkerOp_QueryValidDerivers - putS storePath path - - Some (QueryDerivationOutputs path) -> mapPutE $ do - putS workerOp WorkerOp_QueryDerivationOutputs - putS storePath path - - Some (QueryDerivationOutputNames path) -> mapPutE $ do - putS workerOp WorkerOp_QueryDerivationOutputNames - putS storePath path - - Some (QueryPathFromHashPart pathHashPart) -> mapPutE $ do - putS workerOp WorkerOp_QueryPathFromHashPart - putS storePathHashPart pathHashPart - - Some (QueryMissing derived) -> mapPutE $ do - putS workerOp WorkerOp_QueryMissing - putS (set derivedPath) derived - - Some OptimiseStore -> mapPutE $ do - putS workerOp WorkerOp_OptimiseStore - - Some SyncWithGC -> mapPutE $ do - putS workerOp WorkerOp_SyncWithGC - - Some (VerifyStore checkMode repairMode) -> mapPutE $ do - putS workerOp WorkerOp_VerifyStore - putS enum checkMode - putS enum repairMode - } - where - mapGetE - :: Functor m - => SerialT r SError m a - -> SerialT r RequestSError m a - mapGetE = mapErrorST RequestSError_PrimGet - - mapPutE - :: Functor m - => SerialT r SError m a - -> SerialT r RequestSError m a - mapPutE = mapErrorST RequestSError_PrimPut - - notYet - :: MonadError RequestSError m - => WorkerOp - -> m a - notYet = throwError . RequestSError_NotYetImplemented - - reserved - :: MonadError RequestSError m - => WorkerOp - -> m a - reserved = throwError . RequestSError_ReservedOp - --- ** Reply - -data ReplySError - = ReplySError_PrimGet SError - | ReplySError_PrimPut SError - | ReplySError_DerivationOutput SError - | ReplySError_GCResult SError - | ReplySError_Metadata SError - | ReplySError_Missing SError - | ReplySError_Realisation SError - | ReplySError_RealisationWithId SError - | ReplySError_UnexpectedFalseOpSuccess - deriving (Eq, Ord, Generic, Show) - -mapGetER - :: Functor m - => SerialT r SError m a - -> SerialT r ReplySError m a -mapGetER = mapErrorST ReplySError_PrimGet - -mapPutER - :: Functor m - => SerialT r SError m a - -> SerialT r ReplySError m a -mapPutER = mapErrorST ReplySError_PrimPut - --- | Parse a bool returned at the end of simple operations. --- This is always 1 (@True@) so we assert that it really is so. --- Errors for these operations are indicated via @Logger_Error@. -opSuccess :: NixSerializer r ReplySError SuccessCodeReply -opSuccess = Serializer - { getS = do - retCode <- mapGetER $ getS bool - Control.Monad.unless - (retCode == True) - $ throwError ReplySError_UnexpectedFalseOpSuccess - pure SuccessCodeReply - , putS = \_ -> mapPutER $ putS bool True - } - -noop :: a -> NixSerializer r ReplySError a -noop ret = Serializer - { getS = pure ret - , putS = \_ -> pure () - } - --- *** Realisation - -derivationOutputTyped :: NixSerializer r ReplySError (System.Nix.Realisation.DerivationOutput OutputName) -derivationOutputTyped = mapErrorS ReplySError_DerivationOutput $ - mapPrismSerializer - ( Data.Bifunctor.first SError_DerivationOutput - . System.Nix.Realisation.derivationOutputParser - System.Nix.OutputName.mkOutputName - ) - ( Data.Text.Lazy.toStrict - . Data.Text.Lazy.Builder.toLazyText - . System.Nix.Realisation.derivationOutputBuilder - System.Nix.OutputName.unOutputName - ) - text - -realisation :: NixSerializer r ReplySError Realisation -realisation = mapErrorS ReplySError_Realisation json - -realisationWithId :: NixSerializer r ReplySError RealisationWithId -realisationWithId = mapErrorS ReplySError_RealisationWithId json - --- *** BuildResult - -buildResult - :: ( HasProtoVersion r - , HasStoreDir r - ) - => NixSerializer r ReplySError BuildResult -buildResult = Serializer - { getS = do - pv <- Control.Monad.Reader.asks hasProtoVersion - - buildResultStatus <- mapGetER $ getS enum - buildResultErrorMessage <- mapGetER $ getS maybeText - - ( buildResultTimesBuilt - , buildResultIsNonDeterministic - , buildResultStartTime - , buildResultStopTime - ) <- - if protoVersion_minor pv >= 29 - then mapGetER $ do - tb <- (\case 0 -> Nothing; x -> Just x) <$> getS int - nondet <- getS bool - start <- (\case x | x == t0 -> Nothing; x -> Just x) <$> getS time - end <- (\case x | x == t0 -> Nothing; x -> Just x) <$> getS time - pure $ (tb, pure nondet, start, end) - else pure $ (Nothing, Nothing, Nothing, Nothing) - - buildResultBuiltOutputs <- - if protoVersion_minor pv >= 28 - then - pure - . Data.Map.Strict.fromList - . map (\(_, RealisationWithId (a, b)) -> (a, b)) - . Data.Map.Strict.toList - <$> getS (mapS derivationOutputTyped realisationWithId) - else pure Nothing - pure BuildResult{..} - - , putS = \BuildResult{..} -> do - pv <- Control.Monad.Reader.asks hasProtoVersion - - mapPutER $ putS enum buildResultStatus - mapPutER $ putS maybeText buildResultErrorMessage - Control.Monad.when (protoVersion_minor pv >= 29) $ mapPutER $ do - putS int $ Data.Maybe.fromMaybe 0 buildResultTimesBuilt - putS bool $ Data.Maybe.fromMaybe False buildResultIsNonDeterministic - putS time $ Data.Maybe.fromMaybe t0 buildResultStartTime - putS time $ Data.Maybe.fromMaybe t0 buildResultStopTime - Control.Monad.when (protoVersion_minor pv >= 28) - $ putS (mapS derivationOutputTyped realisationWithId) - $ Data.Map.Strict.fromList - $ map (\(a, b) -> (a, RealisationWithId (a, b))) - $ Data.Map.Strict.toList - $ Data.Maybe.fromMaybe mempty buildResultBuiltOutputs - } - where - t0 :: UTCTime - t0 = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0 - --- *** GCResult - -gcResult - :: HasStoreDir r - => NixSerializer r ReplySError GCResult -gcResult = mapErrorS ReplySError_GCResult $ Serializer - { getS = do - gcResultDeletedPaths <- getS (hashSet storePath) - gcResultBytesFreed <- getS int - Control.Monad.void $ getS (int @Word64) -- obsolete - pure GCResult{..} - , putS = \GCResult{..} -> do - putS (hashSet storePath) gcResultDeletedPaths - putS int gcResultBytesFreed - putS (int @Word64) 0 -- obsolete - } - --- *** GCRoot - -gcRoot :: NixSerializer r ReplySError GCRoot -gcRoot = Serializer - { getS = mapGetER $ do - getS byteString >>= \case - p | p == censored -> pure GCRoot_Censored - p -> pure (GCRoot_Path p) - , putS = mapPutER . putS byteString . \case - GCRoot_Censored -> censored - GCRoot_Path p -> p - } - where censored = Data.ByteString.Char8.pack "{censored}" - --- *** Missing - -missing - :: HasStoreDir r - => NixSerializer r ReplySError Missing -missing = mapErrorS ReplySError_Missing $ Serializer - { getS = do - missingWillBuild <- getS (hashSet storePath) - missingWillSubstitute <- getS (hashSet storePath) - missingUnknownPaths <- getS (hashSet storePath) - missingDownloadSize <- getS int - missingNarSize <- getS int - - pure Missing{..} - , putS = \Missing{..} -> do - putS (hashSet storePath) missingWillBuild - putS (hashSet storePath) missingWillSubstitute - putS (hashSet storePath) missingUnknownPaths - putS int missingDownloadSize - putS int missingNarSize - } - --- *** Maybe (Metadata StorePath) - -maybePathMetadata - :: HasStoreDir r - => NixSerializer r ReplySError (Maybe (Metadata StorePath)) -maybePathMetadata = mapErrorS ReplySError_Metadata $ Serializer - { getS = do - valid <- getS bool - if valid - then pure <$> getS pathMetadata - else pure Nothing - , putS = \case - Nothing -> putS bool False - Just pm -> putS bool True >> putS pathMetadata pm + , mapErrorS + -- * Errors + , SError(..) + -- ** Runners + , runExceptT + , runG + , runP + -- * Primitives + , int + , bool + , byteString + , enum + , text + , maybeText + -- * UTCTime + , time + -- * Combinators + , list + , set + , hashSet + , mapS + , mapS' + , vector + , json + -- * ProtoVersion + , protoVersion + , protoFeature + , protoFeatures + -- * StorePath + , storePath + , maybePath + , storePathHashPart + , storePathName + -- * Metadata + , pathMetadata + , validPathInfo + -- * OutputName + , outputName + -- * Signatures + , signature + , narSignature + -- * Some HashAlgo + , someHashAlgo + -- * Digest + , digest + -- * DSum HashAlgo Digest + , namedDigest + -- * Derivation + , basicDerivation + -- * Derivation + , derivedPath + , singleDerivedPath + -- * Build + , buildMode + -- * Logger + , LoggerSError(..) + , activityID + , maybeActivity + , activity + , activityResult + , field + , trace + , errorInfo + , loggerOpCode + , logger + , verbosity + -- * Handshake + , HandshakeSError(..) + , workerMagic + , trustedFlag + -- * Worker protocol + , storeText + , workerOp + -- ** Request + , RequestSError(..) + , storeRequest + -- ** Reply + , ReplySError(..) + , opSuccess + , noop + -- *** Realisation + , realisation + -- *** BuildResult + , buildResult + -- *** GCResult + , gcResult + -- *** GCResult + , gcRoot + -- *** Missing + , missing + -- *** Maybe (Metadata StorePath) + , maybePathMetadata + ) where + + +import Control.Monad qualified +import Control.Monad.Except (MonadError, throwError, ) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Except (ExceptT(..), runExceptT, withExceptT) +import Crypto.Hash (Digest, HashAlgorithm, SHA256) +import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson qualified +import Data.Attoparsec.Text qualified +import Data.Bifunctor qualified +import Data.Bits qualified +import Data.ByteString (ByteString) +import Data.ByteString qualified +import Data.ByteString.Char8 qualified +import Data.ByteString.Lazy qualified +import Data.Dependent.Sum (DSum((:=>))) +import Data.Fixed (Uni) +import Data.Functor.Identity +import Data.HashSet (HashSet) +import Data.HashSet qualified +import Data.Hashable (Hashable) +import Data.Map (Map) +import Data.Map.Strict qualified +import Data.Maybe qualified +import Data.Serialize.Get qualified +import Data.Serialize.Put qualified +import Data.Serializer +import Data.Set (Set) +import Data.Set qualified +import Data.Some (Some(Some)) +import Data.Some qualified +import Data.Text (Text) +import Data.Text qualified +import Data.Text.Encoding qualified +import Data.Text.Lazy qualified +import Data.Text.Lazy.Builder (Builder) +import Data.Text.Lazy.Builder qualified +import Data.Time (NominalDiffTime, UTCTime) +import Data.Time.Clock.POSIX qualified +import Data.Vector (Vector) +import Data.Vector qualified +import Data.Word (Word8, Word32, Word64) +import GHC.Generics (Generic) +import System.Nix.Base (BaseEncoding(Base16, NixBase32)) +import System.Nix.Base qualified +import System.Nix.Build (BuildMode, BuildResult(..), BuildSuccess(..), BuildFailure(..), BuildSuccessStatus(..), BuildFailureStatus(..)) +import System.Nix.ContentAddress (ContentAddress, methodAlgoBuilder, methodAlgoParser) +import System.Nix.ContentAddress qualified +import System.Nix.Derivation.Traditional +import System.Nix.Derivation +import System.Nix.DerivedPath (DerivedPath(..), SingleDerivedPath(..), ParseOutputsError) +import System.Nix.DerivedPath qualified +import System.Nix.Hash (HashAlgo(..)) +import System.Nix.Hash qualified +import System.Nix.JSON () +import System.Nix.OutputName (OutputName) +import System.Nix.OutputName qualified +import System.Nix.Realisation (Realisation(..)) +import System.Nix.Signature (Signature, NamedSignature) +import System.Nix.Signature qualified +import System.Nix.Store.Remote.Types +import System.Nix.Store.Types (RepairMode(..)) +import System.Nix.StorePath (StoreDir, InvalidNameError, InvalidPathError, StorePath, StorePathHashPart, StorePathName) +import System.Nix.StorePath qualified +import System.Nix.StorePath.Metadata (Metadata(..), StorePathTrust(..)) + +mapErrorS + :: (e -> e') + -> NixSerializer e a + -> NixSerializer e' a +mapErrorS f s = Serializer + { getS = withExceptT f $ getS s + , putS = putS s + } + +-- * NixSerializer + +type NixSerializer e = Serializer (ExceptT e) + +-- * Errors + +data SError + = SError + | SError_BadPadding + { badPaddingStr :: ByteString + , badPaddingLen :: Int + , badPaddingPads :: [Word8] + } + | SError_ContentAddress String + | SError_DerivedPath ParseOutputsError + | SError_Digest String + | SError_EnumOutOfMinBound Int + | SError_EnumOutOfMaxBound Int + | SError_HashAlgo String + | SError_IllegalBool Word64 + | SError_InvalidNixBase32 + | SError_JSONDecoding String + | SError_NarHashMustBeSHA256 + | SError_Name InvalidNameError + | SError_Path InvalidPathError + | SError_Signature String + | SError_SingleDerivedPathInvalidTag Word64 + | SError_UnknownProtoFeature Text + | SError_InvalidWorkerOp Word64 + deriving (Eq, Generic, Show) + + +-- ** Runners + +runG + :: NixSerializer e a + -> ByteString + -> Either (GetSerializerError e) a +runG serializer = + transformGetError + . runGetS + serializer + (runExceptT) + +runP + :: NixSerializer e a + -> a + -> ByteString +runP = runPutS + +-- * Primitives + +int :: Integral a => NixSerializer e a +int = Serializer + { getS = fromIntegral <$> lift Data.Serialize.Get.getWord64le + , putS = Data.Serialize.Put.putWord64le . fromIntegral + } + +bool :: NixSerializer SError Bool +bool = Serializer + { getS = getS (int @Word64) >>= \case + 0 -> pure False + 1 -> pure True + x -> throwError $ SError_IllegalBool x + , putS = \case + False -> putS (int @Word8) 0 + True -> putS (int @Word8) 1 + } + +byteString :: NixSerializer SError ByteString +byteString = Serializer + { getS = do + len <- getS int + st <- lift $ Data.Serialize.Get.getByteString len + Control.Monad.when (len `mod` 8 /= 0) $ do + pads <- unpad $ fromIntegral $ 8 - (len `mod` 8) + Control.Monad.unless + (all (== 0) pads) + $ throwError + $ SError_BadPadding st len pads + pure st + , putS = \x -> do + let len = Data.ByteString.length x + putS int len + Data.Serialize.Put.putByteString x + Control.Monad.when + (len `mod` 8 /= 0) + $ pad $ 8 - (len `mod` 8) + } + where + unpad count = + Control.Monad.replicateM + count + (lift Data.Serialize.Get.getWord8) + pad count = + Control.Monad.replicateM_ + count + (Data.Serialize.Put.putWord8 0) + +maybeByteString :: NixSerializer SError (Maybe ByteString) +maybeByteString = mapIsoSerializer + (\case + t | Data.ByteString.null t -> Nothing + t | otherwise -> Just t + ) + (Data.Maybe.fromMaybe mempty) + byteString + +-- | Utility toEnum version checking bounds using Bounded class +toEnumCheckBoundsM + :: forall a m + . ( Bounded a + , Enum a + , MonadError SError m + ) + => Int + -> m a +toEnumCheckBoundsM = \case + x | x < fromEnum (minBound @a) -> throwError $ SError_EnumOutOfMinBound x + x | x > fromEnum (maxBound @a) -> throwError $ SError_EnumOutOfMaxBound x + x | otherwise -> pure $ toEnum x + +enum + :: ( Bounded a + , Enum a + ) + => NixSerializer SError a +enum = Serializer + { getS = getS int >>= toEnumCheckBoundsM + , putS = putS int . fromEnum + } + +text :: NixSerializer SError Text +text = mapIsoSerializer + Data.Text.Encoding.decodeUtf8 + Data.Text.Encoding.encodeUtf8 + byteString + +-- TODO Parser Builder +_textBuilder :: NixSerializer SError Builder +_textBuilder = Serializer + { getS = Data.Text.Lazy.Builder.fromText <$> getS text + , putS = putS text . Data.Text.Lazy.toStrict . Data.Text.Lazy.Builder.toLazyText + } + +maybeText :: NixSerializer SError (Maybe Text) +maybeText = mapIsoSerializer + (\case + t | Data.Text.null t -> Nothing + t | otherwise -> Just t + ) + (Data.Maybe.fromMaybe mempty) + text + +-- * UTCTime + +time :: NixSerializer e UTCTime +time = Serializer + { getS = + Data.Time.Clock.POSIX.posixSecondsToUTCTime + . toPicoSeconds + <$> getS int + , putS = + putS int + . fromPicoSeconds + . Data.Time.Clock.POSIX.utcTimeToPOSIXSeconds + } + where + -- fancy (*10^12), from Int to Uni to Pico(seconds) + toPicoSeconds :: Int -> NominalDiffTime + toPicoSeconds n = realToFrac (toEnum n :: Uni) + + -- fancy (`div`10^12), from Pico to Uni to Int + fromPicoSeconds :: NominalDiffTime -> Int + fromPicoSeconds = (fromEnum :: Uni -> Int) . realToFrac + +-- * Combinators + +list + :: NixSerializer e a + -> NixSerializer e [a] +list s = Serializer + { getS = do + count <- getS int + Control.Monad.replicateM count (getS s) + , putS = \xs -> do + putS int (length xs) + mapM_ (putS s) xs + } + +set + :: Ord a + => NixSerializer e a + -> NixSerializer e (Set a) +set = + mapIsoSerializer + Data.Set.fromList + Data.Set.toList + . list + +hashSet + :: ( Eq a + , Hashable a + ) + => NixSerializer e a + -> NixSerializer e (HashSet a) +hashSet = + mapIsoSerializer + Data.HashSet.fromList + Data.HashSet.toList + . list + +mapS' + :: Ord k + => NixSerializer e (k, v) + -> NixSerializer e (Map k v) +mapS' kv = + mapIsoSerializer + Data.Map.Strict.fromList + Data.Map.Strict.toList + $ list + $ kv + +mapS + :: Ord k + => NixSerializer e k + -> NixSerializer e v + -> NixSerializer e (Map k v) +mapS k v = mapS' $ tup k v + +vector + :: Ord a + => NixSerializer e a + -> NixSerializer e (Vector a) +vector = + mapIsoSerializer + Data.Vector.fromList + Data.Vector.toList + . list + +json + :: ( FromJSON a + , ToJSON a + ) + => NixSerializer SError a +json = mapPrismSerializer jsonP + $ mapIsoSerializer + Data.ByteString.Lazy.fromStrict + Data.ByteString.Lazy.toStrict + byteString + +jsonP + :: ( FromJSON a + , ToJSON a + ) + => AlmostPrism (ExceptT SError) Data.ByteString.Lazy.ByteString a +jsonP = AlmostPrism + ( ExceptT + . Identity + . Data.Bifunctor.first SError_JSONDecoding + . Data.Aeson.eitherDecode + ) + Data.Aeson.encode + +-- * ProtoVersion + +-- protoVersion_major & 0xFF00 +-- protoVersion_minor & 0x00FF +-- Features are exchanged separately during handshake, not on wire here. +protoVersion :: NixSerializer e ProtoVersion +protoVersion = Serializer + { getS = do + v <- getS (int @Word32) + pure ProtoVersion + { protoVersion_major = fromIntegral $ Data.Bits.shiftR v 8 + , protoVersion_minor = fromIntegral $ v Data.Bits..&. 0x00FF + , protoVersion_features = mempty + } + , putS = \p -> + putS (int @Word32) + $ ((Data.Bits.shiftL (fromIntegral $ protoVersion_major p :: Word32) 8) + Data.Bits..|. fromIntegral (protoVersion_minor p)) + } + +protoFeature :: NixSerializer SError ProtoFeature +protoFeature = + mapPrismSerializer + (AlmostPrism + (\t -> + maybe + (throwError $ SError_UnknownProtoFeature t) + pure + (protoFeatureFromText t) + ) + protoFeatureToText + ) + text + +-- | Features advertised by the other side during handshake. +-- +-- Unknown features are dropped rather than rejected. The peer may +-- support features we do not know about, and negotiation intersects +-- with our own feature set anyway. +protoFeatures :: NixSerializer SError (Set ProtoFeature) +protoFeatures = Serializer + { getS = + Data.Set.fromList + . Data.Maybe.mapMaybe protoFeatureFromText + <$> getS (list text) + , putS = + putS (list text) + . fmap protoFeatureToText + . Data.Set.toList + } + +-- * StorePath + +storePath :: StoreDir -> NixSerializer SError StorePath +storePath storeDir = mapPrismSerializer (storePathP storeDir) byteString + +storePathP :: StoreDir -> AlmostPrism (ExceptT SError) ByteString StorePath +storePathP storeDir = AlmostPrism + { _almostPrism_get = + ExceptT + . Identity + . Data.Bifunctor.first SError_Path + . System.Nix.StorePath.parsePath storeDir + , _almostPrism_put = System.Nix.StorePath.storePathToRawFilePath storeDir + } + +maybePath + :: StoreDir + -> NixSerializer SError (Maybe StorePath) +maybePath storeDir = mapPrismSerializer (maybeAlmostPrism $ storePathP storeDir) maybeByteString + +storePathHashPart :: NixSerializer SError StorePathHashPart +storePathHashPart = + mapIsoSerializer + System.Nix.StorePath.unsafeMakeStorePathHashPart + System.Nix.StorePath.unStorePathHashPart + $ mapPrismSerializer + (AlmostPrism + (ExceptT + . Identity + . Data.Bifunctor.first (pure SError_InvalidNixBase32) + . System.Nix.Base.decodeWith NixBase32) + (System.Nix.Base.encodeWith NixBase32) + ) + text + +storePathName :: NixSerializer SError StorePathName +storePathName = + mapPrismSerializer + (AlmostPrism + (ExceptT + . Identity + . Data.Bifunctor.first SError_Name + . System.Nix.StorePath.mkStorePathName) + System.Nix.StorePath.unStorePathName + ) + text + +pathMetadata + :: StoreDir + -> NixSerializer SError (Metadata StorePath) +pathMetadata storeDir = Serializer + { getS = do + metadataDeriverPath <- getS $ maybePath storeDir + + digest' <- getS $ digest Base16 + let metadataNarHash = System.Nix.Hash.HashAlgo_SHA256 :=> digest' + + metadataReferences <- getS $ hashSet $ storePath storeDir + metadataRegistrationTime <- getS time + metadataNarBytes <- + (\case + 0 -> Nothing + size -> Just size + ) <$> getS int + metadataTrust <- getS storePathTrust + + metadataSigs <- getS $ set narSignature + metadataContentAddress <- getS maybeContentAddress + + pure $ Metadata{..} + + , putS = \Metadata{..} -> do + putS (maybePath storeDir) metadataDeriverPath + + let putNarHash + :: DSum HashAlgo Digest + -> PutM () + putNarHash = \case + System.Nix.Hash.HashAlgo_SHA256 :=> d + -> putS (digest @SHA256 Base16) d + _ -> error "nar hash must be SHA 256" + -- throwError SError_NarHashMustBeSHA256 + + putNarHash metadataNarHash + + putS (hashSet $ storePath storeDir) metadataReferences + putS time metadataRegistrationTime + putS int $ Data.Maybe.fromMaybe 0 metadataNarBytes + putS storePathTrust metadataTrust + putS (set narSignature) metadataSigs + putS maybeContentAddress metadataContentAddress + } + where + maybeContentAddress + :: NixSerializer SError (Maybe ContentAddress) + maybeContentAddress = + mapPrismSerializer + (maybeAlmostPrism $ AlmostPrism + (ExceptT + . Identity + . Data.Bifunctor.first SError_ContentAddress + . System.Nix.ContentAddress.parseContentAddress + ) + System.Nix.ContentAddress.buildContentAddress + ) + maybeText + + storePathTrust + :: NixSerializer SError StorePathTrust + storePathTrust = + mapIsoSerializer + (\case False -> BuiltElsewhere; True -> BuiltLocally) + (\case BuiltElsewhere -> False; BuiltLocally -> True) + bool + +-- | Read/write a full ValidPathInfo (StorePath + Metadata) as one unit. +validPathInfo + :: StoreDir + -> NixSerializer SError (StorePath, Metadata StorePath) +validPathInfo storeDir = Serializer + { getS = do + path <- getS (storePath storeDir) + metadata <- getS (pathMetadata storeDir) + pure (path, metadata) + , putS = \(path, metadata) -> do + putS (storePath storeDir) path + putS (pathMetadata storeDir) metadata + } + +-- * OutputName + +outputName :: NixSerializer SError OutputName +outputName = + mapIsoSerializer + System.Nix.OutputName.OutputName + System.Nix.OutputName.unOutputName + storePathName + +-- * Signatures + +signature + :: NixSerializer SError Signature +signature = + mapPrismSerializer + (AlmostPrism + (ExceptT + . Identity + . Data.Bifunctor.first SError_Signature + . Data.Attoparsec.Text.parseOnly + System.Nix.Signature.signatureParser) + (System.Nix.Signature.signatureToText) + ) + text + +narSignature + :: NixSerializer SError NamedSignature +narSignature = + mapPrismSerializer + (AlmostPrism + (ExceptT + . Identity + . Data.Bifunctor.first SError_Signature + . Data.Attoparsec.Text.parseOnly + System.Nix.Signature.narSignatureParser) + (System.Nix.Signature.narSignatureToText) + ) + text + +-- * Some HashAlgo + +someHashAlgo :: NixSerializer SError (Some HashAlgo) +someHashAlgo = + mapPrismSerializer + (AlmostPrism + (ExceptT + . Identity + . Data.Bifunctor.first SError_HashAlgo + . System.Nix.Hash.textToAlgo) + (Data.Some.foldSome System.Nix.Hash.algoToText) + ) + text + +-- * Digest + +digest + :: forall a + . HashAlgorithm a + => BaseEncoding + -> NixSerializer SError (Digest a) +digest base = mapPrismSerializer (digestP base) $ text + +digestP + :: forall a + . HashAlgorithm a + => BaseEncoding + -> AlmostPrism (ExceptT SError) Text (Digest a) +digestP base = AlmostPrism + (ExceptT + . Identity + . Data.Bifunctor.first SError_Digest + . System.Nix.Hash.decodeDigestWith @a base) + (System.Nix.Hash.encodeDigestWith base) + +-- * DSum HashAlgo Digest + +namedDigest :: NixSerializer SError (DSum HashAlgo Digest) +namedDigest = Serializer + { getS = do + sriHash <- getS text + let (sriName, _h) = Data.Text.breakOn (Data.Text.singleton '-') sriHash + -- bit hacky since mkNamedDigest does the check + -- that the expected matches but we don't know + -- what we expect here (i.e. handle each HashAlgo) + case System.Nix.Hash.mkNamedDigest sriName sriHash of + Left e -> throwError $ SError_Digest e + Right x -> pure x + -- TODO: we also lack a builder for SRI hashes + -- , putS = putS textBuilder . System.Nix.Hash.algoDigestBuilder + , putS = \(algo :=> d) -> do + putS text + $ System.Nix.Hash.algoToText algo + <> (Data.Text.singleton '-') + <> System.Nix.Hash.encodeDigestWith NixBase32 d + } + +derivationOutput + :: StoreDir + -> NixSerializer SError FreeformDerivationOutput +derivationOutput storeDir = Serializer + { getS = do + rawPath <- getS text + rawMethodHashAlgo <- getS text + rawHash <- getS text + parseRawDerivationOutput storeDir $ RawDerivationOutput {..} + , putS = \output -> do + let RawDerivationOutput {..} = renderRawDerivationOutput storeDir output + putS text rawPath + putS text rawMethodHashAlgo + putS text rawHash + } + +-- * Derivation + +basicDerivation + :: StoreDir + -> NixSerializer SError (TraditionalDerivation' (Set StorePath) FreeformDerivationOutputs) +basicDerivation storeDir = Serializer + { getS = do + anonOutputs <- getS $ mapS' $ tup outputName $ derivationOutput storeDir + anonInputs <- getS $ set $ storePath storeDir + anonPlatform <- getS text + anonBuilder <- getS text + anonArgs <- getS $ vector text + anonEnv <- getS $ mapS text text + pure $ TraditionalDerivation{..} + , putS = \TraditionalDerivation{..} -> do + putS (mapS' $ tup outputName $ derivationOutput storeDir) anonOutputs + putS (set $ storePath storeDir) anonInputs + putS text anonPlatform + putS text anonBuilder + putS (vector text) anonArgs + putS (mapS text text) anonEnv + } + +-- * DerivedPath + +derivedPathNew + :: StoreDir + -> NixSerializer SError DerivedPath +derivedPathNew storeDir = Serializer + { getS = do + p <- getS text + case System.Nix.DerivedPath.parseDerivedPath storeDir p of + Left err -> throwError $ SError_DerivedPath err + Right x -> pure x + , putS = \d -> do + putS text (System.Nix.DerivedPath.derivedPathToText storeDir d) + } + +derivedPath + :: StoreDir + -> NixSerializer SError DerivedPath +derivedPath storeDir = Serializer + { getS = getS $ derivedPathNew storeDir + , putS = putS (derivedPathNew storeDir) + } + +-- | Tagged, recursive format used by the builder-rpc-v0 operations, +-- unlike 'derivedPath' which round-trips through the textual +-- rendering. +singleDerivedPath + :: StoreDir + -> NixSerializer SError SingleDerivedPath +singleDerivedPath storeDir = Serializer + { getS = getS (int @Word64) >>= \case + 0 -> SingleDerivedPath_Opaque <$> getS (storePath storeDir) + 1 -> do + drvPath <- getS (singleDerivedPath storeDir) + output <- getS outputName + pure $ SingleDerivedPath_Built drvPath output + x -> throwError $ SError_SingleDerivedPathInvalidTag x + , putS = \case + SingleDerivedPath_Opaque p -> do + putS (int @Word64) 0 + putS (storePath storeDir) p + SingleDerivedPath_Built drvPath output -> do + putS (int @Word64) 1 + putS (singleDerivedPath storeDir) drvPath + putS outputName output + } + +-- * Build + +buildMode :: NixSerializer SError BuildMode +buildMode = enum + +-- * Logger + +data LoggerSError + = LoggerSError_Prim SError + | LoggerSError_InvalidOpCode Word64 + | LoggerSError_UnknownLogFieldType Word8 + deriving (Eq, Generic, Show) + +mapPrimE + :: Functor m + => ExceptT SError m a + -> ExceptT LoggerSError m a +mapPrimE = withExceptT LoggerSError_Prim + +maybeActivity :: NixSerializer LoggerSError (Maybe Activity) +maybeActivity = Serializer + { getS = getS (int @Int) >>= \case + 0 -> pure Nothing + x -> mapPrimE $ toEnumCheckBoundsM (x - 100) >>= pure . Just + , putS = \case + Nothing -> putS (int @Int) 0 + Just act -> putS activity act + } + +activity :: NixSerializer LoggerSError Activity +activity = Serializer + { getS = mapPrimE $ getS int >>= toEnumCheckBoundsM . (+(-100)) + , putS = putS int . (+100) . fromEnum + } + +activityID :: NixSerializer LoggerSError ActivityID +activityID = mapIsoSerializer ActivityID unActivityID int + +activityResult :: NixSerializer LoggerSError ActivityResult +activityResult = Serializer + { getS = mapPrimE $ getS int >>= toEnumCheckBoundsM . (+(-100)) + , putS = putS int . (+100) . fromEnum + } + +field :: NixSerializer LoggerSError Field +field = Serializer + { getS = getS (int @Word8) >>= \case + 0 -> Field_LogInt <$> getS int + 1 -> Field_LogStr <$> mapPrimE (getS text) + x -> throwError $ LoggerSError_UnknownLogFieldType x + , putS = \case + Field_LogInt x -> putS int (0 :: Word8) >> putS int x + Field_LogStr x -> putS int (1 :: Word8) >> putS text x + } + +trace :: NixSerializer LoggerSError Trace +trace = Serializer + { getS = do + tracePosition <- (\case 0 -> Nothing; x -> Just x) <$> getS (int @Int) + traceHint <- mapPrimE $ getS text + pure Trace{..} + , putS = \Trace{..} -> do + putS int $ Data.Maybe.fromMaybe 0 tracePosition + putS text traceHint + } + +errorInfo :: NixSerializer LoggerSError ErrorInfo +errorInfo = Serializer + { getS = do + etyp <- mapPrimE $ getS text + Control.Monad.unless (etyp == Data.Text.pack "Error") + $ fail + $ "get ErrorInfo: received unknown error type" ++ show etyp + errorInfoLevel <- getS verbosity + _name <- mapPrimE $ getS text -- removed error name + errorInfoMessage <- mapPrimE $ getS text + errorInfoPosition <- (\case 0 -> Nothing; x -> Just x) <$> getS int + errorInfoTraces <- getS (list trace) + pure ErrorInfo{..} + + , putS = \ErrorInfo{..} -> do + do + putS text $ Data.Text.pack "Error" + putS verbosity errorInfoLevel + do + putS text $ Data.Text.pack "Error" -- removed error name + putS text errorInfoMessage + putS int $ Data.Maybe.fromMaybe 0 errorInfoPosition + putS (list trace) errorInfoTraces + } + +loggerOpCode :: NixSerializer LoggerSError LoggerOpCode +loggerOpCode = Serializer + { getS = do + c <- getS int + either + (pure $ throwError (LoggerSError_InvalidOpCode c)) + pure + $ word64ToLoggerOpCode c + , putS = putS int . loggerOpCodeToWord64 + } + +logger + :: ProtoVersion + -> NixSerializer LoggerSError Logger +logger _pv = Serializer + { getS = getS loggerOpCode >>= \case + LoggerOpCode_Next -> + mapPrimE $ + Logger_Next <$> getS text + + LoggerOpCode_Read -> + Logger_Read <$> getS int + + LoggerOpCode_Write -> + mapPrimE $ + Logger_Write <$> getS byteString + + LoggerOpCode_Last -> + pure Logger_Last + + LoggerOpCode_Error -> do + Logger_Error <$> getS errorInfo + + LoggerOpCode_StartActivity -> do + startActivityID <- getS activityID + startActivityVerbosity <- getS verbosity + startActivityType <- getS maybeActivity + startActivityString <- mapPrimE $ getS byteString + startActivityFields <- getS (list field) + startActivityParentID <- getS activityID + pure Logger_StartActivity{..} + + LoggerOpCode_StopActivity -> do + stopActivityID <- getS activityID + pure Logger_StopActivity{..} + + LoggerOpCode_Result -> do + resultActivityID <- getS activityID + resultType <- getS activityResult + resultFields <- getS (list field) + pure Logger_Result {..} + + , putS = \case + Logger_Next s -> do + putS loggerOpCode LoggerOpCode_Next + putS text s + + Logger_Read i -> do + putS loggerOpCode LoggerOpCode_Read + putS int i + + Logger_Write s -> do + putS loggerOpCode LoggerOpCode_Write + putS byteString s + + Logger_Last -> + putS loggerOpCode LoggerOpCode_Last + + Logger_Error e -> do + putS loggerOpCode LoggerOpCode_Error + putS errorInfo e + + Logger_StartActivity{..} -> do + putS loggerOpCode LoggerOpCode_StartActivity + putS activityID startActivityID + putS verbosity startActivityVerbosity + putS maybeActivity startActivityType + putS byteString startActivityString + putS (list field) startActivityFields + putS activityID startActivityParentID + + Logger_StopActivity{..} -> do + putS loggerOpCode LoggerOpCode_StopActivity + putS activityID stopActivityID + + Logger_Result{..} -> do + putS loggerOpCode LoggerOpCode_Result + putS activityID resultActivityID + putS activityResult resultType + putS (list field) resultFields + } + +verbosity :: NixSerializer LoggerSError Verbosity +verbosity = Serializer + { getS = mapPrimE $ getS enum + , putS = putS enum + } + +-- * Handshake + +data HandshakeSError + = HandshakeSError_InvalidWorkerMagic Word64 + | HandshakeSError_InvalidTrustedFlag Word8 + deriving (Eq, Ord, Generic, Show) + +workerMagic :: NixSerializer HandshakeSError WorkerMagic +workerMagic = Serializer + { getS = do + c <- getS int + either + (pure $ throwError (HandshakeSError_InvalidWorkerMagic c)) + pure + $ word64ToWorkerMagic c + , putS = putS int . workerMagicToWord64 + } + +trustedFlag :: NixSerializer HandshakeSError (Maybe TrustedFlag) +trustedFlag = Serializer + { getS = do + n :: Word8 <- getS int + case n of + 0 -> return $ Nothing + 1 -> return $ Just TrustedFlag_Trusted + 2 -> return $ Just TrustedFlag_NotTrusted + _ -> throwError (HandshakeSError_InvalidTrustedFlag n) + , putS = \n -> putS int $ case n of + Nothing -> 0 :: Word8 + Just TrustedFlag_Trusted -> 1 + Just TrustedFlag_NotTrusted -> 2 + } + +-- * Worker protocol + +storeText :: NixSerializer SError StoreText +storeText = Serializer + { getS = do + storeTextName <- getS storePathName + storeTextText <- getS text + pure StoreText{..} + , putS = \StoreText{..} -> do + putS storePathName storeTextName + putS text storeTextText + } + +workerOp :: NixSerializer SError WorkerOp +workerOp = Serializer + { getS = getS int >>= + either + (throwError . SError_InvalidWorkerOp) + pure + . word64ToWorkerOp + , putS = putS int . workerOpToWord64 + } + +-- * Request + +data RequestSError + = RequestSError_NotYetImplemented WorkerOp + | RequestSError_ReservedOp WorkerOp + | RequestSError_PrimGet SError + | RequestSError_PrimWorkerOp SError + deriving (Eq, Generic, Show) + +storeRequest + :: StoreDir + -> ProtoVersion + -> NixSerializer RequestSError (Some StoreRequest) +storeRequest storeDir _pv = Serializer + { getS = withExceptT RequestSError_PrimWorkerOp (getS workerOp) >>= \case + WorkerOp_AddToStore -> mapGetE $ do + pathName <- getS storePathName + camStr <- getS text + (method, hashAlgo) <- case Data.Attoparsec.Text.parseOnly methodAlgoParser camStr of + Left e -> fail e + Right x -> pure x + refs <- getS (set (storePath storeDir)) + repairBool <- getS bool + let repair = if repairBool then RepairMode_DoRepair else RepairMode_DontRepair + pure $ Some (AddToStore pathName method hashAlgo refs repair) + + WorkerOp_AddToStoreScanning -> mapGetE $ do + pathName <- getS storePathName + camStr <- getS text + (method, hashAlgo) <- case Data.Attoparsec.Text.parseOnly methodAlgoParser camStr of + Left e -> fail e + Right x -> pure x + pure $ Some (AddToStoreScanning pathName method hashAlgo) + + WorkerOp_AddToStoreNar -> mapGetE $ do + storePath' <- getS $ storePath storeDir + metadata <- getS $ pathMetadata storeDir + repair <- getS bool + let repairMode = if repair then RepairMode_DoRepair else RepairMode_DontRepair + dontCheckSigs <- getS bool + let checkSigs = if dontCheckSigs then CheckMode_DontCheck else CheckMode_DoCheck + + pure $ Some (AddToStoreNar storePath' metadata repairMode checkSigs) + + WorkerOp_AddTextToStore -> mapGetE $ do + txt <- getS storeText + paths <- getS $ hashSet $ storePath storeDir + let repair = RepairMode_DontRepair + pure $ Some (AddTextToStore txt paths repair) + + WorkerOp_AddSignatures -> mapGetE $ do + path <- getS $ storePath storeDir + signatures <- getS (set signature) + pure $ Some (AddSignatures path signatures) + + WorkerOp_AddIndirectRoot -> mapGetE $ do + Some . AddIndirectRoot <$> getS (storePath storeDir) + + WorkerOp_AddTempRoot -> mapGetE $ do + Some . AddTempRoot <$> getS (storePath storeDir) + + WorkerOp_BuildPaths -> mapGetE $ do + derived <- getS (set $ derivedPath storeDir) + buildMode' <- getS buildMode + pure $ Some (BuildPaths derived buildMode') + + WorkerOp_BuildDerivation -> mapGetE $ do + path <- getS $ storePath storeDir + let name = System.Nix.StorePath.storePathName path + drv0 <- getS $ basicDerivation storeDir + let drv1 = withName name drv0 + outputs <- toSpecificOutputs storeDir name $ outputs drv1 + let drv2 = drv1 { outputs = outputs } + buildMode' <- getS buildMode + pure $ Some (BuildDerivation path drv2 buildMode') + + WorkerOp_CollectGarbage -> mapGetE $ do + gcOptionsOperation <- getS enum + gcOptionsPathsToDelete <- getS (hashSet $ storePath storeDir) + gcOptionsIgnoreLiveness <- getS bool + gcOptionsMaxFreed <- getS int + -- obsolete fields + Control.Monad.forM_ [0..(2 :: Word8)] + $ pure $ getS (int @Word8) + pure $ Some (CollectGarbage GCOptions{..}) + + WorkerOp_EnsurePath -> mapGetE $ do + Some . EnsurePath <$> getS (storePath storeDir) + + WorkerOp_FindRoots -> mapGetE $ do + pure $ Some FindRoots + + WorkerOp_IsValidPath -> mapGetE $ do + Some . IsValidPath <$> getS (storePath storeDir) + + WorkerOp_NarFromPath -> mapGetE $ do + Some . NarFromPath <$> getS (storePath storeDir) + + WorkerOp_QueryValidPaths -> mapGetE $ do + paths <- getS (hashSet $ storePath storeDir) + substituteMode <- getS enum + pure $ Some (QueryValidPaths paths substituteMode) + + WorkerOp_QueryAllValidPaths -> mapGetE $ do + pure $ Some QueryAllValidPaths + + WorkerOp_QuerySubstitutablePaths -> mapGetE $ do + Some . QuerySubstitutablePaths <$> getS (hashSet $ storePath storeDir) + + WorkerOp_QueryPathInfo -> mapGetE $ do + Some . QueryPathInfo <$> getS (storePath storeDir) + + WorkerOp_QueryReferrers -> mapGetE $ do + Some . QueryReferrers <$> getS (storePath storeDir) + + WorkerOp_QueryValidDerivers -> mapGetE $ do + Some . QueryValidDerivers <$> getS (storePath storeDir) + + WorkerOp_QueryDerivationOutputs -> mapGetE $ do + Some . QueryDerivationOutputs <$> getS (storePath storeDir) + + WorkerOp_QueryDerivationOutputNames -> mapGetE $ do + Some . QueryDerivationOutputNames <$> getS (storePath storeDir) + + WorkerOp_QueryPathFromHashPart -> mapGetE $ do + Some . QueryPathFromHashPart <$> getS storePathHashPart + + WorkerOp_QueryMissing -> mapGetE $ do + Some . QueryMissing <$> getS (set $ derivedPath storeDir) + + WorkerOp_OptimiseStore -> mapGetE $ do + pure $ Some OptimiseStore + + WorkerOp_SubmitOutput -> mapGetE $ do + path <- getS $ singleDerivedPath storeDir + output <- getS outputName + pure $ Some (SubmitOutput path output) + + WorkerOp_SyncWithGC -> mapGetE $ do + pure $ Some SyncWithGC + + WorkerOp_VerifyStore -> mapGetE $ do + checkMode <- getS enum + repairMode <- getS enum + + pure $ Some (VerifyStore checkMode repairMode) + + w@WorkerOp_Reserved_0__ -> reserved w + w@WorkerOp_Reserved_2__ -> reserved w + w@WorkerOp_Reserved_15__ -> reserved w + w@WorkerOp_Reserved_17__ -> reserved w + + w@WorkerOp_AddBuildLog -> notYet w + w@WorkerOp_AddMultipleToStore -> notYet w + w@WorkerOp_BuildPathsWithResults -> notYet w + w@WorkerOp_ClearFailedPaths -> notYet w + w@WorkerOp_ExportPath -> notYet w + w@WorkerOp_HasSubstitutes -> notYet w + w@WorkerOp_ImportPaths -> notYet w + w@WorkerOp_QueryDerivationOutputMap -> notYet w + w@WorkerOp_QueryDeriver -> notYet w + w@WorkerOp_QueryFailedPaths -> notYet w + w@WorkerOp_QueryPathHash -> notYet w + w@WorkerOp_QueryRealisation -> notYet w + w@WorkerOp_QuerySubstitutablePathInfo -> notYet w + w@WorkerOp_QuerySubstitutablePathInfos -> notYet w + w@WorkerOp_QueryReferences -> notYet w + w@WorkerOp_RegisterDrvOutput -> notYet w + w@WorkerOp_SetOptions -> notYet w + + , putS = \case + Some (AddToStore pathName method hashAlgo refs repair) -> do + putS workerOp WorkerOp_AddToStore + + putS storePathName pathName + putS text + $ Data.Text.Lazy.toStrict + $ Data.Text.Lazy.Builder.toLazyText + $ methodAlgoBuilder method hashAlgo + putS (set (storePath storeDir)) refs + putS bool (repair == RepairMode_DoRepair) + + Some (AddToStoreScanning pathName method hashAlgo) -> do + putS workerOp WorkerOp_AddToStoreScanning + + putS storePathName pathName + putS text + $ Data.Text.Lazy.toStrict + $ Data.Text.Lazy.Builder.toLazyText + $ methodAlgoBuilder method hashAlgo + + Some (AddToStoreNar storePath' metadata repair checkSigs) -> do + putS workerOp WorkerOp_AddToStoreNar + + putS (storePath storeDir) storePath' + putS (pathMetadata storeDir) metadata + putS bool $ repair == RepairMode_DoRepair + putS bool $ checkSigs == CheckMode_DontCheck + + Some (AddTextToStore txt paths _repair) -> do + putS workerOp WorkerOp_AddTextToStore + + putS storeText txt + putS (hashSet $ storePath storeDir) paths + + Some (AddSignatures path signatures) -> do + putS workerOp WorkerOp_AddSignatures + + putS (storePath storeDir) path + putS (set signature) signatures + + Some (AddIndirectRoot path) -> do + putS workerOp WorkerOp_AddIndirectRoot + putS (storePath storeDir) path + + Some (AddTempRoot path) -> do + putS workerOp WorkerOp_AddTempRoot + putS (storePath storeDir) path + + Some (BuildPaths derived buildMode') -> do + putS workerOp WorkerOp_BuildPaths + + putS (set $ derivedPath storeDir) derived + putS buildMode buildMode' + + Some (BuildDerivation path drv0 buildMode') -> do + putS workerOp WorkerOp_BuildDerivation + + putS (storePath storeDir) path + let drv1 = drv0 { outputs = fromSpecificOutputs storeDir (name drv0) $ outputs drv0 } + let drv2 = withoutName drv1 + putS (basicDerivation storeDir) drv2 + putS buildMode buildMode' + + Some (CollectGarbage GCOptions{..}) -> do + putS workerOp WorkerOp_CollectGarbage + + putS enum gcOptionsOperation + putS (hashSet $ storePath storeDir) gcOptionsPathsToDelete + putS bool gcOptionsIgnoreLiveness + putS int gcOptionsMaxFreed + -- obsolete fields + Control.Monad.forM_ [0..(2 :: Word8)] + $ pure $ putS int (0 :: Word8) + + Some (EnsurePath path) -> do + putS workerOp WorkerOp_EnsurePath + putS (storePath storeDir) path + + Some FindRoots -> do + putS workerOp WorkerOp_FindRoots + + Some (IsValidPath path) -> do + putS workerOp WorkerOp_IsValidPath + putS (storePath storeDir) path + + Some (NarFromPath path) -> do + putS workerOp WorkerOp_NarFromPath + putS (storePath storeDir) path + + Some (QueryValidPaths paths substituteMode) -> do + putS workerOp WorkerOp_QueryValidPaths + + putS (hashSet $ storePath storeDir) paths + putS enum substituteMode + + Some QueryAllValidPaths -> do + putS workerOp WorkerOp_QueryAllValidPaths + + Some (QuerySubstitutablePaths paths) -> do + putS workerOp WorkerOp_QuerySubstitutablePaths + putS (hashSet $ storePath storeDir) paths + + Some (QueryPathInfo path) -> do + putS workerOp WorkerOp_QueryPathInfo + putS (storePath storeDir) path + + Some (QueryReferrers path) -> do + putS workerOp WorkerOp_QueryReferrers + putS (storePath storeDir) path + + Some (QueryValidDerivers path) -> do + putS workerOp WorkerOp_QueryValidDerivers + putS (storePath storeDir) path + + Some (QueryDerivationOutputs path) -> do + putS workerOp WorkerOp_QueryDerivationOutputs + putS (storePath storeDir) path + + Some (QueryDerivationOutputNames path) -> do + putS workerOp WorkerOp_QueryDerivationOutputNames + putS (storePath storeDir) path + + Some (QueryPathFromHashPart pathHashPart) -> do + putS workerOp WorkerOp_QueryPathFromHashPart + putS storePathHashPart pathHashPart + + Some (QueryMissing derived) -> do + putS workerOp WorkerOp_QueryMissing + putS (set $ derivedPath storeDir) derived + + Some OptimiseStore -> do + putS workerOp WorkerOp_OptimiseStore + + Some (SubmitOutput path output) -> do + putS workerOp WorkerOp_SubmitOutput + + putS (singleDerivedPath storeDir) path + putS outputName output + + Some SyncWithGC -> do + putS workerOp WorkerOp_SyncWithGC + + Some (VerifyStore checkMode repairMode) -> do + putS workerOp WorkerOp_VerifyStore + putS enum checkMode + putS enum repairMode + } + where + mapGetE + :: Functor m + => ExceptT SError m a + -> ExceptT RequestSError m a + mapGetE = withExceptT RequestSError_PrimGet + + notYet + :: MonadError RequestSError m + => WorkerOp + -> m a + notYet = throwError . RequestSError_NotYetImplemented + + reserved + :: MonadError RequestSError m + => WorkerOp + -> m a + reserved = throwError . RequestSError_ReservedOp + +-- ** Reply + +data ReplySError + = ReplySError_PrimGet SError + | ReplySError_GCResult SError + | ReplySError_Metadata SError + | ReplySError_Missing SError + | ReplySError_Realisation SError + | ReplySError_RealisationWithId SError + | ReplySError_UnexpectedFalseOpSuccess + deriving (Eq, Generic, Show) + +mapGetER + :: Functor m + => ExceptT SError m a + -> ExceptT ReplySError m a +mapGetER = withExceptT ReplySError_PrimGet + +-- | Parse a bool returned at the end of simple operations. +-- This is always 1 (@True@) so we assert that it really is so. +-- Errors for these operations are indicated via @Logger_Error@. +opSuccess :: NixSerializer ReplySError SuccessCodeReply +opSuccess = Serializer + { getS = do + retCode <- mapGetER $ getS bool + Control.Monad.unless + (retCode == True) + $ throwError ReplySError_UnexpectedFalseOpSuccess + pure SuccessCodeReply + , putS = \_ -> putS bool True + } + +noop :: a -> NixSerializer ReplySError a +noop ret = Serializer + { getS = pure ret + , putS = \_ -> pure () + } + +-- *** Realisation + +realisation :: NixSerializer ReplySError Realisation +realisation = mapErrorS ReplySError_Realisation json + +-- *** BuildResult + +buildResult + :: StoreDir + -> ProtoVersion + -> NixSerializer ReplySError BuildResult +buildResult _storeDir pv = Serializer + { getS = do + statusWord <- mapGetER $ getS enum + errorMessage <- mapGetER $ getS maybeText + + ( buildResultTimesBuilt + , isNonDeterministic + , buildResultStartTime + , buildResultStopTime + ) <- + mapGetER $ do + tb <- getS int + nondet <- getS bool + start <- (\case x | x == t0 -> Nothing; x -> Just x) <$> getS time + end <- (\case x | x == t0 -> Nothing; x -> Just x) <$> getS time + pure $ (tb, nondet, start, end) + + Control.Monad.unless (hasFeature ProtoFeature_RealisationWithPathNotHash pv) + $ fail "missing required feature: realisation-with-path-not-hash" + parsedBuiltOutputs <- + getS (mapS (mapErrorS ReplySError_PrimGet outputName) realisation) + + let buildResultStatus = case (wireToStatus statusWord, errorMessage) of + (Right successStatus, _) -> Right $ BuildSuccess successStatus parsedBuiltOutputs + (Left failureStatus, Just errorMsg) -> Left $ BuildFailure failureStatus errorMsg isNonDeterministic + (Left failureStatus, Nothing) -> Left $ BuildFailure failureStatus Data.Text.empty isNonDeterministic + + let buildResultStartTime' = Data.Maybe.fromMaybe t0 buildResultStartTime + buildResultStopTime' = Data.Maybe.fromMaybe t0 buildResultStopTime + buildResultCpuUser = Nothing + buildResultCpuSystem = Nothing + + pure BuildResult + { buildResultStatus = buildResultStatus + , buildResultTimesBuilt = buildResultTimesBuilt + , buildResultStartTime = buildResultStartTime' + , buildResultStopTime = buildResultStopTime' + , buildResultCpuUser = buildResultCpuUser + , buildResultCpuSystem = buildResultCpuSystem + } + + , putS = \BuildResult{..} -> do + let (statusWord, errorMessage, isNonDeterministic) = case buildResultStatus of + Right (BuildSuccess st _bo) -> (successStatusToWire st, Nothing, False) + Left (BuildFailure st em nd) -> (failureStatusToWire st, Just em, nd) + + putS enum statusWord + putS maybeText errorMessage + putS int buildResultTimesBuilt + putS bool isNonDeterministic + putS time buildResultStartTime + putS time buildResultStopTime + let builtOutputs = case buildResultStatus of + Right (BuildSuccess _ bo) -> bo + Left _ -> mempty + putS (mapS (mapErrorS ReplySError_PrimGet outputName) realisation) builtOutputs + } + where + t0 :: UTCTime + t0 = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0 + + -- Convert wire format status code to either success or failure status + wireToStatus :: Word8 -> Either BuildFailureStatus BuildSuccessStatus + wireToStatus 0 = Right BuildSuccessStatus_Built + wireToStatus 1 = Right BuildSuccessStatus_Substituted + wireToStatus 2 = Right BuildSuccessStatus_AlreadyValid + wireToStatus 3 = Left BuildFailureStatus_PermanentFailure + wireToStatus 4 = Left BuildFailureStatus_InputRejected + wireToStatus 5 = Left BuildFailureStatus_OutputRejected + wireToStatus 6 = Left BuildFailureStatus_TransientFailure + wireToStatus 7 = Left BuildFailureStatus_CachedFailure + wireToStatus 8 = Left BuildFailureStatus_TimedOut + wireToStatus 9 = Left BuildFailureStatus_MiscFailure + wireToStatus 10 = Left BuildFailureStatus_DependencyFailed + wireToStatus 11 = Left BuildFailureStatus_LogLimitExceeded + wireToStatus 12 = Left BuildFailureStatus_NotDeterministic + wireToStatus 13 = Right BuildSuccessStatus_ResolvesToAlreadyValid + wireToStatus 14 = Left BuildFailureStatus_NoSubstituters + wireToStatus 15 = Left BuildFailureStatus_HashMismatch + wireToStatus _ = Left BuildFailureStatus_MiscFailure + + -- Convert success status to wire format + successStatusToWire :: BuildSuccessStatus -> Word8 + successStatusToWire BuildSuccessStatus_Built = 0 + successStatusToWire BuildSuccessStatus_Substituted = 1 + successStatusToWire BuildSuccessStatus_AlreadyValid = 2 + successStatusToWire BuildSuccessStatus_ResolvesToAlreadyValid = 13 + + -- Convert failure status to wire format + failureStatusToWire :: BuildFailureStatus -> Word8 + failureStatusToWire BuildFailureStatus_PermanentFailure = 3 + failureStatusToWire BuildFailureStatus_InputRejected = 4 + failureStatusToWire BuildFailureStatus_OutputRejected = 5 + failureStatusToWire BuildFailureStatus_TransientFailure = 6 + failureStatusToWire BuildFailureStatus_CachedFailure = 7 + failureStatusToWire BuildFailureStatus_TimedOut = 8 + failureStatusToWire BuildFailureStatus_MiscFailure = 9 + failureStatusToWire BuildFailureStatus_DependencyFailed = 10 + failureStatusToWire BuildFailureStatus_LogLimitExceeded = 11 + failureStatusToWire BuildFailureStatus_NotDeterministic = 12 + failureStatusToWire BuildFailureStatus_NoSubstituters = 14 + failureStatusToWire BuildFailureStatus_HashMismatch = 15 + +-- *** GCResult + +gcResult + :: StoreDir + -> NixSerializer ReplySError GCResult +gcResult storeDir = mapErrorS ReplySError_GCResult $ Serializer + { getS = do + gcResultDeletedPaths <- getS (hashSet $ storePath storeDir) + gcResultBytesFreed <- getS int + Control.Monad.void $ getS (int @Word64) -- obsolete + pure GCResult{..} + , putS = \GCResult{..} -> do + putS (hashSet $ storePath storeDir) gcResultDeletedPaths + putS int gcResultBytesFreed + putS (int @Word64) 0 -- obsolete + } + +-- *** GCRoot + +gcRoot :: NixSerializer ReplySError GCRoot +gcRoot = Serializer + { getS = mapGetER $ do + getS byteString >>= \case + p | p == censored -> pure GCRoot_Censored + p -> pure (GCRoot_Path p) + , putS = putS byteString . \case + GCRoot_Censored -> censored + GCRoot_Path p -> p + } + where censored = Data.ByteString.Char8.pack "{censored}" + +-- *** Missing + +missing + :: StoreDir + -> NixSerializer ReplySError Missing +missing storeDir = mapErrorS ReplySError_Missing $ Serializer + { getS = do + missingWillBuild <- getS (hashSet $ storePath storeDir) + missingWillSubstitute <- getS (hashSet $ storePath storeDir) + missingUnknownPaths <- getS (hashSet $ storePath storeDir) + missingDownloadSize <- getS int + missingNarSize <- getS int + + pure Missing{..} + , putS = \Missing{..} -> do + putS (hashSet $ storePath storeDir) missingWillBuild + putS (hashSet $ storePath storeDir) missingWillSubstitute + putS (hashSet $ storePath storeDir) missingUnknownPaths + putS int missingDownloadSize + putS int missingNarSize + } + +-- *** Maybe (Metadata StorePath) + +maybePathMetadata + :: StoreDir + -> NixSerializer ReplySError (Maybe (Metadata StorePath)) +maybePathMetadata storeDir = mapErrorS ReplySError_Metadata $ Serializer + { getS = do + valid <- getS bool + if valid + then pure <$> getS (pathMetadata storeDir) + else pure Nothing + , putS = \case + Nothing -> putS bool False + Just pm -> putS bool True >> putS (pathMetadata storeDir) pm } diff --git a/src/System/Nix/Store/Remote/Server.hs b/src/System/Nix/Store/Remote/Server.hs --- a/src/System/Nix/Store/Remote/Server.hs +++ b/src/System/Nix/Store/Remote/Server.hs @@ -6,8 +6,9 @@ ) where +import Algebra.PartialOrd (leq) import Control.Concurrent.Classy.Async -import Control.Monad (join, void, when) +import Control.Monad (join, unless, void, when) import Control.Monad.Conc.Class (MonadConc) import Control.Monad.Except (MonadError, throwError) import Control.Monad.Trans (lift) @@ -15,26 +16,28 @@ import Data.Default.Class (Default(def)) import Data.Foldable (traverse_) import Data.IORef (IORef, atomicModifyIORef, newIORef) +import Data.Set qualified import Data.Text (Text) import Data.Void (Void, absurd) -import Data.Word (Word32) +import Data.ByteString (ByteString) +import Data.Word (Word32, Word64) import Network.Socket (Socket, accept, close, listen, maxListenQueue) import System.Nix.Nar (NarSource) import System.Nix.Store.Remote.Client (Run, doReq) -import System.Nix.Store.Remote.Serializer (LoggerSError, mapErrorS, storeRequest, workerMagic, protoVersion, int, logger, text, trustedFlag) +import System.Nix.Store.Remote.Serializer (LoggerSError, mapErrorS, storeRequest, validPathInfo, workerMagic, protoFeatures, protoVersion, int, logger, text, trustedFlag) import System.Nix.Store.Remote.Socket import System.Nix.Store.Remote.Types.StoreRequest as R import System.Nix.Store.Remote.Types.StoreReply -import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..)) -import System.Nix.Store.Remote.Types.Logger (BasicError(..), ErrorInfo, Logger(..)) +import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..), minVersionNumber) +import System.Nix.Store.Remote.Types.Logger (ErrorInfo, Logger(..)) import System.Nix.Store.Remote.MonadStore (MonadRemoteStore(..), WorkerError(..), WorkerException(..), RemoteStoreError(..), RemoteStoreT, runRemoteStoreT) import System.Nix.Store.Remote.Types.Handshake (ServerHandshakeInput(..), ServerHandshakeOutput(..)) import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..)) -import qualified Data.Some -import qualified Data.Text -import qualified Data.Text.IO -import qualified System.Timeout -import qualified Network.Socket.ByteString +import Data.Some qualified +import Data.Text.IO qualified +import Data.Bits (shiftL) +import Data.ByteString qualified +import Network.Socket.ByteString qualified type WorkerHelper m = forall a @@ -124,20 +127,13 @@ special <- case req of AddToStore {} -> do - -- This is a hack (but a pretty neat and fast one!) - -- it should parse nad stream NAR instead let proxyNarSource :: NarSource IO - proxyNarSource f = - liftIO - (System.Timeout.timeout - 1000000 - (Network.Socket.ByteString.recv sock 8) - ) - >>= \case - Nothing -> pure () - Just x -> f x >> proxyNarSource f - + proxyNarSource sink = readFramedSource sock sink pure $ setNarSource proxyNarSource + AddToStoreScanning {} -> do + let proxyNarSource :: NarSource IO + proxyNarSource sink = readFramedSource sock sink + pure $ setNarSource proxyNarSource _ -> pure $ pure () res <- @@ -149,21 +145,52 @@ case fst res of Left e -> throwError e - Right reply -> - sockPutS - (mapErrorS - RemoteStoreError_SerializerReply - $ getReplyS - ) - reply + Right reply -> do + storeDir <- getStoreDir + pv <- getProtoVersion + case req of + -- AddToStore returns ValidPathInfo on the wire, + -- not just StorePath + AddToStore {} -> do + -- Query the metadata so we can send full ValidPathInfo + metadata <- lift $ workerHelper $ doReq (QueryPathInfo reply) + case fst metadata of + Left e -> throwError e + Right (Just meta) -> + sockPutS + (mapErrorS RemoteStoreError_SerializerPut + $ validPathInfo storeDir) + (reply, meta) + Right Nothing -> + throwError $ RemoteStoreError_Fixme "AddToStore: path not found after adding" + AddToStoreScanning {} -> do + metadata <- lift $ workerHelper $ doReq (QueryPathInfo reply) + case fst metadata of + Left e -> throwError e + Right (Just meta) -> + sockPutS + (mapErrorS RemoteStoreError_SerializerPut + $ validPathInfo storeDir) + (reply, meta) + Right Nothing -> + throwError $ RemoteStoreError_Fixme "AddToStoreScanning: path not found after adding" + _ -> + sockPutS + (mapErrorS + RemoteStoreError_SerializerReply + $ getReplyS storeDir pv + ) + reply -- Process client requests. let loop = do + storeDir <- getStoreDir + pv <- getProtoVersion someReq <- sockGetS $ mapErrorS RemoteStoreError_SerializerRequest - storeRequest + (storeRequest storeDir pv) -- have to be explicit here -- because otherwise GHC can't conjure Show a, StoreReply a @@ -171,6 +198,7 @@ () <- Data.Some.withSome someReq $ \case r@AddToStore {} -> perform r r@AddToStoreNar {} -> perform r + r@AddToStoreScanning {} -> perform r r@AddTextToStore {} -> perform r r@AddSignatures {} -> perform r r@AddTempRoot {} -> perform r @@ -193,6 +221,7 @@ r@QueryPathFromHashPart {} -> perform r r@QueryMissing {} -> perform r r@OptimiseStore {} -> perform r + r@SubmitOutput {} -> perform r r@SyncWithGC {} -> perform r r@VerifyStore {} -> perform r loop @@ -230,42 +259,45 @@ clientVersion <- sockGetS protoVersion - let leastCommonVersion = min clientVersion serverHandshakeInputOurVersion + let leastCommonVersion = minVersionNumber clientVersion serverHandshakeInputOurVersion - when (clientVersion < ProtoVersion 1 10) + when (not (ProtoVersion 1 37 mempty `leq` clientVersion)) $ throwError $ RemoteStoreError_WorkerException WorkerException_ClientVersionTooOld - when (clientVersion >= ProtoVersion 1 14) $ do - x :: Word32 <- sockGetS int - when (x /= 0) $ do - -- Obsolete CPU affinity. - _ :: Word32 <- sockGetS int - pure () + -- Feature exchange (>= 1.38) + negotiatedFeatures <- if ProtoVersion 1 38 mempty `leq` leastCommonVersion + then do + clientFeatures <- sockGetS + $ mapErrorS RemoteStoreError_SerializerGet protoFeatures + sockPutS + (mapErrorS RemoteStoreError_SerializerPut protoFeatures) + (protoVersion_features serverHandshakeInputOurVersion) + pure $ Data.Set.intersection clientFeatures (protoVersion_features serverHandshakeInputOurVersion) + else pure mempty - when (clientVersion >= ProtoVersion 1 11) $ do - _ :: Word32 <- sockGetS int -- obsolete reserveSpace + let leastCommonVersionWithFeatures = leastCommonVersion { protoVersion_features = negotiatedFeatures } + + -- postHandshake: read affinity (obsolete), reserveSpace (obsolete) + x :: Word32 <- sockGetS int + when (x /= 0) $ do + -- Obsolete CPU affinity. + _ :: Word32 <- sockGetS int pure () - when (clientVersion >= ProtoVersion 1 33) $ do - sockPutS - (mapErrorS - RemoteStoreError_SerializerPut - text - ) - serverHandshakeInputNixVersion + _ :: Word32 <- sockGetS int -- obsolete reserveSpace - when (clientVersion >= ProtoVersion 1 35) $ do - sockPutS - (mapErrorS - RemoteStoreError_SerializerHandshake - trustedFlag - ) - serverHandshakeInputTrust + sockPutS + (mapErrorS RemoteStoreError_SerializerPut text) + serverHandshakeInputNixVersion + sockPutS + (mapErrorS RemoteStoreError_SerializerHandshake trustedFlag) + serverHandshakeInputTrust + pure ServerHandshakeOutput - { serverHandshakeOutputLeastCommonVersion = leastCommonVersion + { serverHandshakeOutputLeastCommonVersion = leastCommonVersionWithFeatures , serverHandshakeOutputClientVersion = clientVersion } @@ -306,7 +338,7 @@ -> Logger -> m () enqueueMsg x l = updateLogger x $ \st@(TunnelLoggerState c p) -> case c of - True -> (st, sockPutS logger l) + True -> (st, do pv <- getProtoVersion; sockPutS (logger pv) l) False -> (TunnelLoggerState c (l:p), pure ()) _log @@ -323,17 +355,19 @@ => TunnelLogger -> m () startWork x = updateLogger x $ \(TunnelLoggerState _ p) -> (,) - (TunnelLoggerState True []) $ - (traverse_ (sockPutS logger') $ reverse p) - where logger' = mapErrorS RemoteStoreError_SerializerLogger logger + (TunnelLoggerState True []) $ do + pv <- getProtoVersion + let logger' = mapErrorS RemoteStoreError_SerializerLogger (logger pv) + traverse_ (sockPutS logger') $ reverse p stopWork :: MonadRemoteStore m => TunnelLogger -> m () stopWork x = updateLogger x $ \_ -> (,) - (TunnelLoggerState False []) - (sockPutS (mapErrorS RemoteStoreError_SerializerLogger logger) Logger_Last) + (TunnelLoggerState False []) $ do + pv <- getProtoVersion + sockPutS (mapErrorS RemoteStoreError_SerializerLogger (logger pv)) Logger_Last -- | Stop sending logging and report an error. -- @@ -351,11 +385,10 @@ case _tunnelLoggerState_canSendStderr st of False -> (st, pure False) True -> (,) (TunnelLoggerState False []) $ do - getProtoVersion >>= \pv -> if protoVersion_minor pv >= 26 - then sockPutS logger' (Logger_Error (Right ex)) - else sockPutS logger' (Logger_Error (Left (BasicError 0 (Data.Text.pack $ show ex)))) + pv <- getProtoVersion + let logger' = mapErrorS RemoteStoreError_SerializerLogger (logger pv) + sockPutS logger' (Logger_Error ex) pure True - where logger' = mapErrorS RemoteStoreError_SerializerLogger logger updateLogger :: MonadRemoteStore m @@ -363,3 +396,46 @@ -> (TunnelLoggerState -> (TunnelLoggerState, m a)) -> m a updateLogger x = join . liftIO . atomicModifyIORef (_tunnelLogger_state x) + +-- | Read framed source data from a socket. +-- +-- The framed protocol sends chunks as: little-endian u64 length +-- followed by that many raw bytes, terminated by a zero-length frame. +readFramedSource + :: Socket + -> (ByteString -> IO ()) + -> IO () +readFramedSource sock sink = go + where + go = do + chunkLen <- recvWord64le sock + unless (chunkLen == 0) $ do + recvExact sock (fromIntegral chunkLen) sink + go + + recvWord64le :: Socket -> IO Word64 + recvWord64le s = do + bs <- recvExactBS s 8 + pure $ sum + [ fromIntegral (Data.ByteString.index bs i) `shiftL` (i * 8) + | i <- [0..7] + ] + + recvExactBS :: Socket -> Int -> IO ByteString + recvExactBS s n = do + bs <- Network.Socket.ByteString.recv s n + let got = Data.ByteString.length bs + if got == 0 then fail "readFramedSource: unexpected EOF" + else if got == n then pure bs + else do + rest <- recvExactBS s (n - got) + pure $ bs <> rest + + recvExact :: Socket -> Int -> (ByteString -> IO ()) -> IO () + recvExact s remaining f = when (remaining > 0) $ do + let toRead = min 16384 remaining + bs <- Network.Socket.ByteString.recv s toRead + let got = Data.ByteString.length bs + when (got == 0) $ fail "readFramedSource: unexpected EOF" + f bs + recvExact s (remaining - got) f diff --git a/src/System/Nix/Store/Remote/Socket.hs b/src/System/Nix/Store/Remote/Socket.hs --- a/src/System/Nix/Store/Remote/Socket.hs +++ b/src/System/Nix/Store/Remote/Socket.hs @@ -7,13 +7,12 @@ import Data.Serialize.Put (Put, runPut) import Network.Socket.ByteString (recv, sendAll) import System.Nix.Store.Remote.MonadStore (MonadRemoteStore(..), RemoteStoreError(..)) -import System.Nix.Store.Remote.Serializer (NixSerializer, runP, runSerialT) -import System.Nix.Store.Remote.Types (ProtoStoreConfig) +import System.Nix.Store.Remote.Serializer (NixSerializer, runExceptT, runP) -import qualified Control.Exception -import qualified Data.ByteString -import qualified Data.Serializer -import qualified Data.Serialize.Get +import Control.Exception qualified +import Data.ByteString qualified +import Data.Serializer qualified +import Data.Serialize.Get qualified genericIncremental :: ( MonadIO m @@ -70,18 +69,13 @@ liftIO $ sendAll soc $ runPut p sockPutS - :: ( MonadRemoteStore m - , MonadError e m - ) - => NixSerializer ProtoStoreConfig e a + :: MonadRemoteStore m + => NixSerializer e a -> a -> m () sockPutS s a = do - cfg <- getConfig sock <- getStoreSocket - case runP s cfg a of - Right x -> liftIO $ sendAll sock x - Left e -> throwError e + liftIO $ sendAll sock $ runP s a sockGetS :: ( MonadRemoteStore m @@ -89,12 +83,11 @@ , Show a , Show e ) - => NixSerializer ProtoStoreConfig e a + => NixSerializer e a -> m a sockGetS s = do - cfg <- getConfig res <- genericIncremental sockGet8 - $ runSerialT cfg $ Data.Serializer.getS s + $ runExceptT $ Data.Serializer.getS s case res of Right x -> pure x diff --git a/src/System/Nix/Store/Remote/Types/Handshake.hs b/src/System/Nix/Store/Remote/Types/Handshake.hs --- a/src/System/Nix/Store/Remote/Types/Handshake.hs +++ b/src/System/Nix/Store/Remote/Types/Handshake.hs @@ -13,7 +13,7 @@ -- | Data sent by the client during initial protocol handshake data ClientHandshakeInput = ClientHandshakeInput { clientHandshakeInputOurVersion :: ProtoVersion -- ^ Our protocol version (that we advertise to the server) - } deriving (Eq, Generic, Ord, Show) + } deriving (Eq, Generic, Show) -- | Data received by the client via initial protocol handshake data ClientHandshakeOutput = ClientHandshakeOutput @@ -21,17 +21,17 @@ , clientHandshakeOutputTrust :: Maybe TrustedFlag -- ^ Whether remote side trusts us , clientHandshakeOutputLeastCommonVersion :: ProtoVersion -- ^ Minimum protocol version supported by both sides , clientHandshakeOutputServerVersion :: ProtoVersion -- ^ Protocol version supported by the server - } deriving (Eq, Generic, Ord, Show) + } deriving (Eq, Generic, Show) -- | Data sent by the server during initial protocol handshake data ServerHandshakeInput = ServerHandshakeInput { serverHandshakeInputNixVersion :: Text -- ^ Textual version, since 1.33 , serverHandshakeInputOurVersion :: ProtoVersion -- ^ Our protocol version (that we advertise to the client) , serverHandshakeInputTrust :: Maybe TrustedFlag -- ^ Whether client should trusts us - } deriving (Eq, Generic, Ord, Show) + } deriving (Eq, Generic, Show) -- | Data received by the server during initial protocol handshake data ServerHandshakeOutput = ServerHandshakeOutput { serverHandshakeOutputLeastCommonVersion :: ProtoVersion -- ^ Minimum protocol version supported by both sides , serverHandshakeOutputClientVersion :: ProtoVersion -- ^ Protocol version supported by the client - } deriving (Eq, Generic, Ord, Show) + } deriving (Eq, Generic, Show) diff --git a/src/System/Nix/Store/Remote/Types/Logger.hs b/src/System/Nix/Store/Remote/Types/Logger.hs --- a/src/System/Nix/Store/Remote/Types/Logger.hs +++ b/src/System/Nix/Store/Remote/Types/Logger.hs @@ -1,7 +1,6 @@ module System.Nix.Store.Remote.Types.Logger ( Field(..) , Trace(..) - , BasicError(..) , ErrorInfo(..) , Logger(..) , LoggerOpCode(..) @@ -29,14 +28,7 @@ } deriving (Eq, Generic, Ord, Show) -data BasicError = BasicError - { basicErrorExitStatus :: Int - , basicErrorMessage :: Text - } - deriving (Eq, Generic, Ord, Show) - -- | Extended error info --- available for protoVersion_minor >= 26 data ErrorInfo = ErrorInfo { errorInfoLevel :: Verbosity , errorInfoMessage :: Text @@ -84,7 +76,7 @@ | Logger_Read Word64 -- data needed from source | Logger_Write ByteString -- data for sink | Logger_Last - | Logger_Error (Either BasicError ErrorInfo) + | Logger_Error ErrorInfo | Logger_StartActivity { startActivityID :: ActivityID , startActivityVerbosity :: Verbosity diff --git a/src/System/Nix/Store/Remote/Types/ProtoVersion.hs b/src/System/Nix/Store/Remote/Types/ProtoVersion.hs --- a/src/System/Nix/Store/Remote/Types/ProtoVersion.hs +++ b/src/System/Nix/Store/Remote/Types/ProtoVersion.hs @@ -1,24 +1,99 @@ +{-# LANGUAGE OverloadedStrings #-} module System.Nix.Store.Remote.Types.ProtoVersion ( ProtoVersion(..) + , ProtoFeature(..) + , protoFeatureToText + , protoFeatureFromText , HasProtoVersion(..) + , hasFeature + , minVersionNumber + , builderRpcV0 ) where +import Algebra.PartialOrd (PartialOrd(..)) import Data.Default.Class (Default(def)) +import Data.Set (Set) +import Data.Set qualified +import Data.Text (Text) import Data.Word (Word8, Word16) import GHC.Generics (Generic) +-- | An optional protocol capability, negotiated during handshake. +data ProtoFeature + = ProtoFeature_AddToStoreScanning + -- ^ The AddToStoreScanning operation, only offered by the daemon + -- inside derivation builds with the @recursive-nix@ or + -- @builder-rpc-v0@ system feature. + | ProtoFeature_DisableSetOptions + -- ^ The client promises not to send SetOptions after handshake. + | ProtoFeature_RealisationWithPathNotHash + -- ^ Use StorePath-based realisations instead of hash-based ones. + | ProtoFeature_SubmitOutput + -- ^ The SubmitOutput operation, only offered by the daemon inside + -- derivation builds with the @builder-rpc-v0@ system feature. + deriving (Bounded, Enum, Eq, Generic, Ord, Show) + +-- | The name of a feature as exchanged on the wire. +protoFeatureToText :: ProtoFeature -> Text +protoFeatureToText = \case + ProtoFeature_AddToStoreScanning -> "add-to-store-scanning" + ProtoFeature_DisableSetOptions -> "disable-set-options" + ProtoFeature_RealisationWithPathNotHash -> "realisation-with-path-not-hash" + ProtoFeature_SubmitOutput -> "submit-output" + +protoFeatureFromText :: Text -> Maybe ProtoFeature +protoFeatureFromText t = + lookup t [ (protoFeatureToText f, f) | f <- [minBound .. maxBound] ] + data ProtoVersion = ProtoVersion { protoVersion_major :: Word16 , protoVersion_minor :: Word8 + , protoVersion_features :: Set ProtoFeature } - deriving (Eq, Generic, Ord, Show) + deriving (Eq, Generic, Show) +instance PartialOrd ProtoVersion where + leq a b = + (protoVersion_major a, protoVersion_minor a) + <= (protoVersion_major b, protoVersion_minor b) + && protoVersion_features a `Data.Set.isSubsetOf` protoVersion_features b + +-- | Check whether a protocol version includes a given feature. +hasFeature :: ProtoFeature -> ProtoVersion -> Bool +hasFeature f = Data.Set.member f . protoVersion_features + +-- | Take the minimum by version number, with empty features. +-- Used in handshake before feature negotiation. +minVersionNumber :: ProtoVersion -> ProtoVersion -> ProtoVersion +minVersionNumber a b = + let (major', minor') = min + (protoVersion_major a, protoVersion_minor a) + (protoVersion_major b, protoVersion_minor b) + in ProtoVersion major' minor' mempty + -- | The protocol version we support instance Default ProtoVersion where def = ProtoVersion { protoVersion_major = 1 - , protoVersion_minor = 24 + , protoVersion_minor = 38 + , protoVersion_features = Data.Set.singleton ProtoFeature_RealisationWithPathNotHash } + +-- | The protocol profile spoken on the daemon socket exposed to +-- builders of derivations with the @builder-rpc-v0@ system feature. +-- +-- Frozen upstream, since any change would be derivation-visible. +builderRpcV0 :: ProtoVersion +builderRpcV0 = ProtoVersion + { protoVersion_major = 1 + , protoVersion_minor = 38 + , protoVersion_features = Data.Set.fromList + [ ProtoFeature_RealisationWithPathNotHash + , ProtoFeature_DisableSetOptions + , ProtoFeature_AddToStoreScanning + , ProtoFeature_SubmitOutput + ] + } class HasProtoVersion r where hasProtoVersion :: r -> ProtoVersion diff --git a/src/System/Nix/Store/Remote/Types/StoreConfig.hs b/src/System/Nix/Store/Remote/Types/StoreConfig.hs --- a/src/System/Nix/Store/Remote/Types/StoreConfig.hs +++ b/src/System/Nix/Store/Remote/Types/StoreConfig.hs @@ -24,7 +24,7 @@ data ProtoStoreConfig = ProtoStoreConfig { protoStoreConfigDir :: StoreDir , protoStoreConfigProtoVersion :: ProtoVersion - } deriving (Eq, Generic, Ord, Show) + } deriving (Eq, Generic, Show) instance Default ProtoStoreConfig where def = ProtoStoreConfig def def diff --git a/src/System/Nix/Store/Remote/Types/StoreReply.hs b/src/System/Nix/Store/Remote/Types/StoreReply.hs --- a/src/System/Nix/Store/Remote/Types/StoreReply.hs +++ b/src/System/Nix/Store/Remote/Types/StoreReply.hs @@ -5,14 +5,14 @@ import Data.HashSet (HashSet) import Data.Map (Map) import System.Nix.Build (BuildResult) -import System.Nix.StorePath (StorePath, StorePathName) +import System.Nix.StorePath (StoreDir, StorePath, StorePathName) import System.Nix.StorePath.Metadata (Metadata) import System.Nix.Store.Remote.Serializer import System.Nix.Store.Remote.Types.NoReply (NoReply(..)) import System.Nix.Store.Remote.Types.SuccessCodeReply (SuccessCodeReply) import System.Nix.Store.Remote.Types.GC (GCResult, GCRoot) +import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion) import System.Nix.Store.Remote.Types.Query.Missing (Missing) -import System.Nix.Store.Remote.Types.StoreConfig (ProtoStoreConfig) -- | Get @NixSerializer@ for some type @a@ -- This could also be generalized for every type @@ -20,42 +20,42 @@ -- this for replies and it would make look serializers -- quite hodor, like @a <- getS get; b <- getS get@ class StoreReply a where - getReplyS :: NixSerializer ProtoStoreConfig ReplySError a + getReplyS :: StoreDir -> ProtoVersion -> NixSerializer ReplySError a instance StoreReply SuccessCodeReply where - getReplyS = opSuccess + getReplyS _ _ = opSuccess instance StoreReply NoReply where - getReplyS = noop NoReply + getReplyS _ _ = noop NoReply instance StoreReply Bool where - getReplyS = mapPrimE bool + getReplyS _ _ = mapPrimE bool instance StoreReply BuildResult where - getReplyS = buildResult + getReplyS sd pv = buildResult sd pv instance StoreReply GCResult where - getReplyS = gcResult + getReplyS sd _ = gcResult sd instance StoreReply (Map GCRoot StorePath) where - getReplyS = mapS gcRoot (mapPrimE storePath) + getReplyS sd _ = mapS gcRoot (mapPrimE (storePath sd)) instance StoreReply Missing where - getReplyS = missing + getReplyS sd _ = missing sd instance StoreReply (Maybe (Metadata StorePath)) where - getReplyS = maybePathMetadata + getReplyS sd _ = maybePathMetadata sd instance StoreReply StorePath where - getReplyS = mapPrimE storePath + getReplyS sd _ = mapPrimE (storePath sd) instance StoreReply (HashSet StorePath) where - getReplyS = mapPrimE (hashSet storePath) + getReplyS sd _ = mapPrimE (hashSet (storePath sd)) instance StoreReply (HashSet StorePathName) where - getReplyS = mapPrimE (hashSet storePathName) + getReplyS _ _ = mapPrimE (hashSet storePathName) mapPrimE - :: NixSerializer r SError a - -> NixSerializer r ReplySError a + :: NixSerializer SError a + -> NixSerializer ReplySError a mapPrimE = mapErrorS ReplySError_PrimGet diff --git a/src/System/Nix/Store/Remote/Types/StoreRequest.hs b/src/System/Nix/Store/Remote/Types/StoreRequest.hs --- a/src/System/Nix/Store/Remote/Types/StoreRequest.hs +++ b/src/System/Nix/Store/Remote/Types/StoreRequest.hs @@ -12,15 +12,16 @@ import Data.Kind (Type) import Data.Map (Map) import Data.Set (Set) -import Data.Text (Text) import Data.Some (Some(Some)) import System.Nix.Build (BuildMode, BuildResult) -import System.Nix.Derivation (Derivation) -import System.Nix.DerivedPath (DerivedPath) +import System.Nix.Derivation (BasicDerivation) +import System.Nix.DerivedPath (DerivedPath, SingleDerivedPath) +import System.Nix.ContentAddress (ContentAddressMethod) import System.Nix.Hash (HashAlgo) +import System.Nix.OutputName (OutputName) import System.Nix.Signature (Signature) -import System.Nix.Store.Types (FileIngestionMethod, RepairMode) +import System.Nix.Store.Types (RepairMode) import System.Nix.StorePath (StorePath, StorePathName, StorePathHashPart) import System.Nix.StorePath.Metadata (Metadata) import System.Nix.Store.Remote.Types.GC (GCOptions, GCResult, GCRoot) @@ -35,9 +36,10 @@ -- | Add @NarSource@ to the store. AddToStore :: StorePathName -- ^ Name part of the newly created @StorePath@ - -> FileIngestionMethod -- ^ Add target directory recursively - -> Some HashAlgo -- ^ Nar hashing algorithm - -> RepairMode -- ^ Only used by local store backend + -> ContentAddressMethod -- ^ Content addressing method + -> Some HashAlgo -- ^ Hashing algorithm + -> Set StorePath -- ^ References + -> RepairMode -> StoreRequest StorePath -- | Add a NAR with Metadata to the store. @@ -48,6 +50,18 @@ -> CheckMode -- ^ Whether to check signatures -> StoreRequest NoReply + -- | Add @NarSource@ to the store, letting the daemon scan the + -- contents for references instead of declaring them. + -- + -- Only available inside a derivation build with the + -- @recursive-nix@ or @builder-rpc-v0@ system feature, when the + -- @add-to-store-scanning@ protocol feature was negotiated. + AddToStoreScanning + :: StorePathName -- ^ Name part of the newly created @StorePath@ + -> ContentAddressMethod -- ^ Content addressing method + -> Some HashAlgo -- ^ Hashing algorithm + -> StoreRequest StorePath + -- | Add text to store. -- -- Reference accepts repair but only uses it @@ -84,7 +98,7 @@ BuildDerivation :: StorePath - -> Derivation StorePath Text + -> BasicDerivation -> BuildMode -> StoreRequest BuildResult @@ -155,6 +169,17 @@ OptimiseStore :: StoreRequest SuccessCodeReply + -- | Register a store object as an output of the currently running + -- derivation. + -- + -- Only available inside a derivation build with the + -- @builder-rpc-v0@ system feature, when the @submit-output@ + -- protocol feature was negotiated. + SubmitOutput + :: SingleDerivedPath + -> OutputName + -> StoreRequest SuccessCodeReply + SyncWithGC :: StoreRequest SuccessCodeReply @@ -172,8 +197,9 @@ deriveGShow ''StoreRequest instance {-# OVERLAPPING #-} Eq (Some StoreRequest) where - Some (AddToStore a b c d) == Some (AddToStore a' b' c' d') = (a, b, c, d) == (a', b', c', d') + Some (AddToStore a b c d e) == Some (AddToStore a' b' c' d' e') = (a, b, c, d, e) == (a', b', c', d', e') Some (AddToStoreNar a b c d) == Some (AddToStoreNar a' b' c' d') = (a, b, c, d) == (a', b', c', d') + Some (AddToStoreScanning a b c) == Some (AddToStoreScanning a' b' c') = (a, b, c) == (a', b', c') Some (AddTextToStore a b c) == Some (AddTextToStore a' b' c') = (a, b, c) == (a', b', c') Some (AddSignatures a b) == Some (AddSignatures a' b') = (a, b) == (a', b') Some (AddIndirectRoot a) == Some (AddIndirectRoot a') = a == a' @@ -196,6 +222,7 @@ Some (QueryPathFromHashPart a) == Some (QueryPathFromHashPart a') = a == a' Some (QueryMissing a) == Some (QueryMissing a') = a == a' Some OptimiseStore == Some OptimiseStore = True + Some (SubmitOutput a b) == Some (SubmitOutput a' b') = (a, b) == (a', b') Some SyncWithGC == Some SyncWithGC = True Some (VerifyStore a b) == Some (VerifyStore a' b') = (a, b) == (a', b') diff --git a/src/System/Nix/Store/Remote/Types/WorkerOp.hs b/src/System/Nix/Store/Remote/Types/WorkerOp.hs --- a/src/System/Nix/Store/Remote/Types/WorkerOp.hs +++ b/src/System/Nix/Store/Remote/Types/WorkerOp.hs @@ -1,13 +1,19 @@ -module System.Nix.Store.Remote.Types.WorkerOp +module System.Nix.Store.Remote.Types.WorkerOp ( WorkerOp(..) + , workerOpToWord64 + , word64ToWorkerOp ) where +import Data.Word (Word64) import GHC.Generics (Generic) -- | Worker opcode -- -- This type has gaps filled in so that the GHC builtin --- Enum instance lands on the right values. +-- Enum instance lands on the right values for the contiguous +-- 0-46 range. The builder-rpc-v0 opcodes at 1000+ don't follow +-- the Enum values, so the wire mapping goes through +-- 'workerOpToWord64' and 'word64ToWorkerOp'. data WorkerOp = WorkerOp_Reserved_0__ -- 0 | WorkerOp_IsValidPath -- 1 @@ -56,4 +62,20 @@ | WorkerOp_AddMultipleToStore -- 44 0x2c | WorkerOp_AddBuildLog -- 45 0x2d | WorkerOp_BuildPathsWithResults -- 46 0x2e + | WorkerOp_SubmitOutput -- 1000, builder-rpc-v0 only + | WorkerOp_AddToStoreScanning -- 1001, recursive-nix or builder-rpc-v0 only deriving (Bounded, Eq, Enum, Generic, Ord, Show, Read) + +workerOpToWord64 :: WorkerOp -> Word64 +workerOpToWord64 = \case + WorkerOp_SubmitOutput -> 1000 + WorkerOp_AddToStoreScanning -> 1001 + op -> fromIntegral (fromEnum op) + +word64ToWorkerOp :: Word64 -> Either Word64 WorkerOp +word64ToWorkerOp = \case + 1000 -> Right WorkerOp_SubmitOutput + 1001 -> Right WorkerOp_AddToStoreScanning + x | x <= fromIntegral (fromEnum WorkerOp_BuildPathsWithResults) -> + Right $ toEnum $ fromIntegral x + | otherwise -> Left x diff --git a/tests-io/Main.hs b/tests-io/Main.hs --- a/tests-io/Main.hs +++ b/tests-io/Main.hs @@ -1,7 +1,7 @@ module Main where -import qualified Test.Hspec -import qualified NixDaemonSpec +import Test.Hspec qualified +import NixDaemonSpec qualified -- we run remote tests in -- Linux namespaces to avoid interacting with systems store diff --git a/tests-io/NixDaemonSpec.hs b/tests-io/NixDaemonSpec.hs --- a/tests-io/NixDaemonSpec.hs +++ b/tests-io/NixDaemonSpec.hs @@ -22,31 +22,32 @@ import System.Nix.Hash (HashAlgo(HashAlgo_SHA256)) import System.Nix.Build (BuildMode(..)) import System.Nix.DerivedPath (DerivedPath(..)) +import System.Nix.ContentAddress (ContentAddressMethod(..)) import System.Nix.StorePath (StoreDir(..), StorePath) import System.Nix.StorePath.Metadata (Metadata(..)) import System.Nix.Store.Remote import System.Nix.Store.Remote.Server (WorkerHelper) import System.Process (CreateProcess(..), ProcessHandle) -import qualified Control.Concurrent -import qualified Control.Exception -import qualified Data.ByteString.Char8 -import qualified Data.Either -import qualified Data.HashSet -import qualified Data.Map -import qualified Data.Set -import qualified Data.Text -import qualified Data.Text.Encoding -import qualified DataSink -import qualified SampleNar -import qualified System.Directory -import qualified System.Environment -import qualified System.IO.Temp -import qualified System.Linux.Namespaces -import qualified System.Nix.StorePath -import qualified System.Nix.Nar -import qualified System.Posix.User -import qualified System.Process -import qualified Test.Hspec +import Control.Concurrent qualified +import Control.Exception qualified +import Data.ByteString.Char8 qualified +import Data.Either qualified +import Data.HashSet qualified +import Data.Map qualified +import Data.Set qualified +import Data.Text qualified +import Data.Text.Encoding qualified +import DataSink qualified +import SampleNar qualified +import System.Directory qualified +import System.Environment qualified +import System.IO.Temp qualified +import System.Linux.Namespaces qualified +import System.Nix.StorePath qualified +import System.Nix.Nar qualified +import System.Posix.User qualified +import System.Process qualified +import Test.Hspec qualified createProcessEnv :: FilePath @@ -290,8 +291,9 @@ addToStore (forceRight $ System.Nix.StorePath.mkStorePathName "dummy") (System.Nix.Nar.dumpPath "dummy") - FileIngestionMethod_Flat + ContentAddressMethod_NixArchive (Some HashAlgo_SHA256) + mempty RepairMode_DontRepair invalidPath :: StorePath @@ -457,8 +459,9 @@ addToStore (forceRight $ System.Nix.StorePath.mkStorePathName "tmp-addition") (System.Nix.Nar.dumpPath fp) - FileIngestionMethod_Flat + ContentAddressMethod_NixArchive (Some HashAlgo_SHA256) + mempty RepairMode_DontRepair context "with dummy" $ do diff --git a/tests-io/SampleNar.hs b/tests-io/SampleNar.hs --- a/tests-io/SampleNar.hs +++ b/tests-io/SampleNar.hs @@ -25,8 +25,8 @@ import Data.STRef import Data.Word -import qualified Data.ByteString -import qualified System.Nix.Nar +import Data.ByteString qualified +import System.Nix.Nar qualified -- | Sample data for an AddToStoreNar operation data SampleNar diff --git a/tests/Data/SerializerSpec.hs b/tests/Data/SerializerSpec.hs --- a/tests/Data/SerializerSpec.hs +++ b/tests/Data/SerializerSpec.hs @@ -1,5 +1,6 @@ module Data.SerializerSpec (spec) where +import Control.Monad.Trans.Identity import Data.Some import Data.Serializer import Data.Serializer.Example @@ -10,34 +11,26 @@ spec :: Spec spec = describe "Serializer" $ do prop "Roundtrips GADT protocol" $ \someCmd -> - (runG cmdS - <$> (runP cmdS someCmd)) - `shouldBe` - ((pure $ pure someCmd) :: - Either MyPutError - (Either (GetSerializerError MyGetError) - (Some Cmd))) - - it "Handles putS error" $ - runP cmdSPutError (Some (Cmd_Bool True)) + (runG cmdS $ runP cmdS someCmd) `shouldBe` - Left MyPutError_NoLongerSupported + (pure someCmd :: + Either (GetSerializerError MyGetError) + (Some Cmd)) it "Handles getS error" $ - runG cmdSGetError (runPutSimple cmdS (Some (Cmd_Bool True))) + runG cmdSGetError (runPutS (cmdS @IdentityT) (Some (Cmd_Bool True))) `shouldBe` Left (SerializerError_Get MyGetError_Example) it "Handles getS fail" $ - runG cmdSGetFail (runPutSimple cmdS (Some (Cmd_Bool True))) + runG cmdSGetFail (runPutS (cmdS @IdentityT) (Some (Cmd_Bool True))) `shouldBe` Left (SerializerError_GetFail @MyGetError "Failed reading: no parse\nEmpty call stack\n") prop "Roundtrips elaborate example" $ \someCmd readerBool -> - (runGRest cmdSRest readerBool 0 - <$> (runPRest cmdSRest readerBool 0 someCmd)) + (runGRest (cmdSRest readerBool) readerBool 0 + $ runPRest (cmdSRest readerBool) someCmd) `shouldBe` - ((pure $ pure $ someCmd) :: - Either MyPutError - (Either (GetSerializerError MyGetError) - (Some Cmd))) + (pure someCmd :: + Either (GetSerializerError MyGetError) + (Some Cmd)) diff --git a/tests/EnumSpec.hs b/tests/EnumSpec.hs --- a/tests/EnumSpec.hs +++ b/tests/EnumSpec.hs @@ -4,16 +4,16 @@ import Test.Hspec (SpecWith, Spec, describe, it, shouldBe) -import Data.ByteString (ByteString) import Data.Word (Word64) -import System.Nix.Build (BuildMode(..), BuildStatus(..)) -import System.Nix.Store.Remote.Serializer +import System.Nix.Build (BuildMode(..), BuildSuccessStatus(..), BuildFailureStatus(..)) +import System.Nix.Store.Remote.Serializer ( activity , activityResult , enum , int , loggerOpCode , runP + , workerOp , LoggerSError , NixSerializer , SError @@ -34,22 +34,22 @@ -> SpecWith () itE name constr value = it name - $ ((runP enum () constr) :: Either SError ByteString) + $ runP @SError enum constr `shouldBe` - (runP (int @Word64) () value) + runP @SError (int @Word64) value itE' :: Show a - => NixSerializer () LoggerSError a + => NixSerializer LoggerSError a -> String -> a -> Word64 -> SpecWith () itE' s name constr value = it name - $ ((runP s () constr) :: Either LoggerSError ByteString) + $ runP s constr `shouldBe` - (runP (int @Word64) () (value)) + runP @LoggerSError (int @Word64) value describe "Enums" $ do describe "BuildMode enum order matches Nix" $ do @@ -57,23 +57,26 @@ itE "Repair" BuildMode_Repair 1 itE "Check" BuildMode_Check 2 - describe "BuildStatus enum order matches Nix" $ do - itE "Built" BuildStatus_Built 0 - itE "Substituted" BuildStatus_Substituted 1 - itE "AlreadyValid" BuildStatus_AlreadyValid 2 - itE "PermanentFailure" BuildStatus_PermanentFailure 3 - itE "InputRejected" BuildStatus_InputRejected 4 - itE "OutputRejected" BuildStatus_OutputRejected 5 - itE "TransientFailure" BuildStatus_TransientFailure 6 - itE "CachedFailure" BuildStatus_CachedFailure 7 - itE "TimedOut" BuildStatus_TimedOut 8 - itE "MiscFailure" BuildStatus_MiscFailure 9 - itE "DependencyFailed" BuildStatus_DependencyFailed 10 - itE "LogLimitExceeded" BuildStatus_LogLimitExceeded 11 - itE "NotDeterministic" BuildStatus_NotDeterministic 12 - itE "ResolvesToAlreadyValid" BuildStatus_ResolvesToAlreadyValid 13 - itE "NoSubstituters" BuildStatus_NoSubstituters 14 + describe "BuildSuccessStatus enum order matches Nix" $ do + itE "Built" BuildSuccessStatus_Built 0 + itE "Substituted" BuildSuccessStatus_Substituted 1 + itE "AlreadyValid" BuildSuccessStatus_AlreadyValid 2 + itE "ResolvesToAlreadyValid" BuildSuccessStatus_ResolvesToAlreadyValid 3 + describe "BuildFailureStatus enum order matches Nix" $ do + itE "PermanentFailure" BuildFailureStatus_PermanentFailure 0 + itE "InputRejected" BuildFailureStatus_InputRejected 1 + itE "OutputRejected" BuildFailureStatus_OutputRejected 2 + itE "TransientFailure" BuildFailureStatus_TransientFailure 3 + itE "CachedFailure" BuildFailureStatus_CachedFailure 4 + itE "TimedOut" BuildFailureStatus_TimedOut 5 + itE "MiscFailure" BuildFailureStatus_MiscFailure 6 + itE "DependencyFailed" BuildFailureStatus_DependencyFailed 7 + itE "LogLimitExceeded" BuildFailureStatus_LogLimitExceeded 8 + itE "NotDeterministic" BuildFailureStatus_NotDeterministic 9 + itE "NoSubstituters" BuildFailureStatus_NoSubstituters 10 + itE "HashMismatch" BuildFailureStatus_HashMismatch 11 + describe "GCAction enum order matches Nix" $ do itE "ReturnLive" GCAction_ReturnLive 0 itE "ReturnDead" GCAction_ReturnDead 1 @@ -130,8 +133,15 @@ itE "Vomit" Verbosity_Vomit 7 describe "WorkerOp enum order matches Nix" $ do - itE "IsValidPath" WorkerOp_IsValidPath 1 - itE "BuildPathsWithResults" WorkerOp_BuildPathsWithResults 46 + let itW name constr value = + it name + $ runP workerOp constr + `shouldBe` + runP @SError (int @Word64) value + itW "IsValidPath" WorkerOp_IsValidPath 1 + itW "BuildPathsWithResults" WorkerOp_BuildPathsWithResults 46 + itW "SubmitOutput" WorkerOp_SubmitOutput 1000 + itW "AddToStoreScanning" WorkerOp_AddToStoreScanning 1001 diff --git a/tests/NixSerializerSpec.hs b/tests/NixSerializerSpec.hs --- a/tests/NixSerializerSpec.hs +++ b/tests/NixSerializerSpec.hs @@ -3,63 +3,49 @@ module NixSerializerSpec (spec) where import Crypto.Hash (MD5, SHA1, SHA256, SHA512) -import Data.Some (Some(Some)) +import Data.Set qualified +import Data.Some (Some) import Data.Time (UTCTime) import Test.Hspec (Expectation, Spec, describe, parallel, shouldBe) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (Gen, arbitrary, forAll, suchThat) import System.Nix.Arbitrary () -import System.Nix.Derivation (Derivation(inputDrvs)) -import System.Nix.Build (BuildResult(..)) -import System.Nix.StorePath (StoreDir) +import System.Nix.Build (BuildResult(..), BuildSuccess(..)) +import System.Nix.Derivation.Traditional qualified import System.Nix.Store.Remote.Arbitrary () import System.Nix.Store.Remote.Serializer -import System.Nix.Store.Remote.Types.Logger (Logger(..)) -import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion(..)) -import System.Nix.Store.Remote.Types.StoreConfig (ProtoStoreConfig(..)) +import System.Nix.Store.Remote.Types.Logger () +import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..), ProtoFeature(..)) import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..)) -- | Test for roundtrip using @NixSerializer@ -roundtripSReader - :: forall r e a - . ( Eq a - , Show a - , Eq e - , Show e - ) - => NixSerializer r e a - -> r - -> a - -> Expectation -roundtripSReader serializer readerVal a = - (runG serializer readerVal - <$> runP serializer readerVal a) - `shouldBe` (pure $ pure a) - roundtripS - :: ( Eq a + :: forall e a + . ( Eq a , Show a , Eq e , Show e ) - => NixSerializer () e a + => NixSerializer e a -> a -> Expectation -roundtripS serializer = roundtripSReader serializer () +roundtripS serializer a = + runG serializer (runP serializer a) + `shouldBe` Right a spec :: Spec spec = parallel $ do describe "Prim" $ do - prop "Int" $ roundtripS @Int @() int + prop "Int" $ roundtripS @() @Int int prop "Bool" $ roundtripS bool prop "ByteString" $ roundtripS byteString prop "Text" $ roundtripS text prop "Maybe Text" $ roundtripS maybeText - prop "UTCTime" $ roundtripS @UTCTime @() time + prop "UTCTime" $ roundtripS @() @UTCTime time describe "Combinators" $ do - prop "list" $ roundtripS @[Int] @() (list int) + prop "list" $ roundtripS @() @[Int] (list int) prop "set" $ roundtripS (set byteString) prop "hashSet" $ roundtripS (hashSet byteString) prop "mapS" $ roundtripS (mapS (int @Int) byteString) @@ -67,34 +53,21 @@ describe "Complex" $ do prop "DSum HashAlgo Digest" $ roundtripS namedDigest - describe "BuildResult" $ do - prop "< 1.28" - $ \sd -> forAll (arbitrary `suchThat` ((< 28) . protoVersion_minor)) - $ \pv -> - roundtripSReader @ProtoStoreConfig buildResult (ProtoStoreConfig sd pv) - . (\x -> x { buildResultBuiltOutputs = Nothing }) - . (\x -> x { buildResultTimesBuilt = Nothing - , buildResultIsNonDeterministic = Nothing - , buildResultStartTime = Nothing - , buildResultStopTime = Nothing - } - ) - prop "= 1.28" - $ \sd -> - roundtripSReader @ProtoStoreConfig buildResult (ProtoStoreConfig sd (ProtoVersion 1 28)) - . (\x -> x { buildResultTimesBuilt = Nothing - , buildResultIsNonDeterministic = Nothing - , buildResultStartTime = Nothing - , buildResultStopTime = Nothing - } - ) - prop "> 1.28" - $ \sd -> forAll (arbitrary `suchThat` ((> 28) . protoVersion_minor)) - $ \pv -> - roundtripSReader @ProtoStoreConfig buildResult (ProtoStoreConfig sd pv) + prop "BuildResult" + $ \sd pv -> + let pv' = pv { protoVersion_features = Data.Set.singleton ProtoFeature_RealisationWithPathNotHash } + in roundtripS (buildResult sd pv') + . (\x -> x { buildResultStatus = case buildResultStatus x of + Right (BuildSuccess st _bo) -> Right (BuildSuccess st mempty) + Left f -> Left f + }) + . (\x -> x { buildResultCpuUser = Nothing + , buildResultCpuSystem = Nothing + } + ) - prop "StorePath" $ - roundtripSReader @StoreDir storePath + prop "StorePath" $ \sd -> + roundtripS (storePath sd) prop "StorePathHashPart" $ roundtripS storePathHashPart @@ -102,8 +75,8 @@ prop "StorePathName" $ roundtripS storePathName - prop "Metadata (StorePath)" $ - roundtripSReader @StoreDir pathMetadata + prop "Metadata (StorePath)" $ \sd -> + roundtripS (pathMetadata sd) prop "Some HashAlgo" $ roundtripS someHashAlgo @@ -114,27 +87,30 @@ prop "SHA256" $ roundtripS . digest @SHA256 prop "SHA512" $ roundtripS . digest @SHA512 - prop "Derivation" $ \sd -> - roundtripSReader @StoreDir derivation sd - . (\drv -> drv { inputDrvs = mempty }) + prop "Derivation" $ \sd drv -> + roundtripS (basicDerivation sd) $ + System.Nix.Derivation.Traditional.withoutName drv - prop "ProtoVersion" $ roundtripS @ProtoVersion @() protoVersion + prop "SingleDerivedPath" $ \sd -> + roundtripS (singleDerivedPath sd) + prop "ProtoVersion" $ roundtripS @() @ProtoVersion protoVersion + + prop "ProtoFeature" $ roundtripS protoFeature + prop "Set ProtoFeature" $ roundtripS protoFeatures + describe "Logger" $ do prop "ActivityID" $ roundtripS activityID prop "Maybe Activity" $ roundtripS maybeActivity prop "ActivityResult" $ roundtripS activityResult prop "Field" $ roundtripS field prop "Trace" $ roundtripS trace - prop "BasicError" $ roundtripS basicError prop "ErrorInfo" $ roundtripS errorInfo prop "LoggerOpCode" $ roundtripS loggerOpCode prop "Verbosity" $ roundtripS verbosity prop "Logger" $ forAll (arbitrary :: Gen ProtoVersion) - $ \pv -> - forAll (arbitrary `suchThat` errorInfoIf (protoVersion_minor pv >= 26)) - $ roundtripSReader logger pv + $ \pv -> roundtripS (logger pv) describe "Handshake" $ do prop "WorkerMagic" $ roundtripS workerMagic @@ -145,25 +121,17 @@ prop "StoreText" $ roundtripS storeText prop "StoreRequest" - $ \testStoreConfig -> - forAll (arbitrary `suchThat` (restrictProtoVersion (hasProtoVersion testStoreConfig))) - $ roundtripSReader @ProtoStoreConfig storeRequest testStoreConfig + $ \sd -> forAll arbitrary $ \pv -> + forAll (arbitrary `suchThat` (restrictProtoVersion pv)) + $ roundtripS (storeRequest sd pv) describe "StoreReply" $ do prop "()" $ roundtripS opSuccess - prop "GCResult" $ roundtripSReader @StoreDir gcResult + prop "GCResult" $ \sd -> roundtripS (gcResult sd) prop "GCRoot" $ roundtripS gcRoot - prop "Missing" $ roundtripSReader @StoreDir missing - prop "Maybe (Metadata StorePath)" $ roundtripSReader @StoreDir maybePathMetadata + prop "Missing" $ \sd -> roundtripS (missing sd) + prop "Maybe (Metadata StorePath)" $ \sd -> roundtripS (maybePathMetadata sd) restrictProtoVersion :: ProtoVersion -> Some StoreRequest -> Bool -restrictProtoVersion v (Some (BuildPaths _ _)) | v < ProtoVersion 1 30 = False -restrictProtoVersion _ (Some (BuildDerivation _ drv _)) = inputDrvs drv == mempty -restrictProtoVersion v (Some (QueryMissing _)) | v < ProtoVersion 1 30 = False restrictProtoVersion _ _ = True -errorInfoIf :: Bool -> Logger -> Bool -errorInfoIf True (Logger_Error (Right _)) = True -errorInfoIf False (Logger_Error (Left _)) = True -errorInfoIf _ (Logger_Error _) = False -errorInfoIf _ _ = True