diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,71 @@ +# [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: + * `StorePath` no longer carries `storePathRoot` field and we + have a stand-alone `StoreDir` type instead to be used instead of `FilePath` + when store root directory is needed as a context. + Fore `-remote`, this affects `runStoreOpts` and its variants [#216](https://github.com/haskell-nix/hnix-store/pull/216) + * The old `MonadStore` is now deprecated and aliased to `RemoteStoreT IO` + * All store operations now use `MonadRemoteStore` typeclass, which `RemoteStoreT` is an instance of + * Couple of `Bool` parameters switched to enums + +* Additions + * `addToStoreNAR` store operation [#277](https://github.com/haskell-nix/hnix-store/pull/277) + * `narFromPath` store operation [#279](https://github.com/haskell-nix/hnix-store/pull/279) + * Initial server-side support with proxy daemon acting as MITM proxy, + which allows for testing of both sides of the remote store protocol + +The library stability is not quite there yet and should be considered experimental. + +# [0.6.0.0](https://github.com/haskell-nix/hnix-store/compare/remote-0.5.0.0...remote-0.6.0.0) 2021-06-06 + +* Changes: + * `System.Nix.Store.Remote` [#179](https://github.com/haskell-nix/hnix-store/pull/179) + * `addToStore` no longer accepts `FilePath` as its second argument but uses + more generic `NarSource` [(NarSource PR)](https://github.com/haskell-nix/hnix-store/pull/177) + +# [0.5.0.0](https://github.com/haskell-nix/hnix-store/compare/0.4.3.0...remote-0.5.0.0) 2021-06-11 + +* Changes: + * `System.Nix.Store.Remote` [#161](https://github.com/haskell-nix/hnix-store/pull/161) + * `addToStore`: constraint of `ValidAlgo a` removed in favour of constraint on `cryptonite: HashAlgorithm a` through constraint `NamedAlgo a`. + * `queryPathFromHashPart`: 1st arg changed from `Digest StorePathHashAlgo` to `StorePathHashPart`, for details: [hnix-store-core 0.5.0.0 ChangeLog](https://hackage.haskell.org/package/hnix-store-core-0.5.0.0/changelog). + +# [0.4.3.0](https://github.com/haskell-nix/hnix-store/compare/0.4.2.0...0.4.3.0) 2021-05-30 + +Nothing (it is tandem `hnix-store-core` fix release) + +# [0.4.2.0](https://github.com/haskell-nix/hnix-store/compare/0.4.1.0...0.4.2.0) 2021-03-12 + +* Additions: + * Cabal now properly states `tasty-discover` as `build-tool-depends` [#130](https://github.com/haskell-nix/hnix-store/pull/130) + * added explicit `hie.yml` cradle description for `cabal` to help Haskell Language Server to work with monorepo. [#132](https://github.com/haskell-nix/hnix-store/pull/132) + * Nix dev env: removed GHC 8.6.5 support, afaik it is not even in Nixpkgs anymore [#136](https://github.com/haskell-nix/hnix-store/pull/136) + +# [0.4.1.0](https://github.com/haskell-nix/hnix-store/compare/0.4.0.0...0.4.1.0) 2021-01-16 + +* `System.Nix.Store.Remote`: module API now re-exports `System.Nix.Store.Remote.Types` API +* Big clean-up of dependencies. + +# [0.4.0.0](https://github.com/haskell-nix/hnix-store/compare/0.3.0.0...0.4.0.0) 2020-12-30 + +* `hnix-store-core` compatibility + +# 0.3.0.0 -- 2020-11-29 + +* Restored most store API functions except `addToStoreNar` +* Added `buildDerivation` + +# 0.2.0.0 -- skipped + +* `hnix-store-core` release only + +# 0.1.0.0 -- 2019-03-18 + +* First version. + +--- + +`hnix-store-remote` uses [PVP Versioning][1]. + +[1]: https://pvp.haskell.org diff --git a/ChangeLog.md b/ChangeLog.md deleted file mode 100644 --- a/ChangeLog.md +++ /dev/null @@ -1,52 +0,0 @@ -# Revision history for hnix-store-remote - -## [0.6.0.0](https://github.com/haskell-nix/hnix-store/compare/remote-0.5.0.0...remote-0.6.0.0) 2021-06-06 - -* Breaking: - * [(link)](https://github.com/haskell-nix/hnix-store/pull/179) `System.Nix.Store.Remote`: - * `addToStore` no longer accepts `FilePath` as its second argument but uses - more generic `NarSource` [(NarSource PR)](https://github.com/haskell-nix/hnix-store/pull/177) - -## [0.5.0.0](https://github.com/haskell-nix/hnix-store/compare/0.4.3.0...remote-0.5.0.0) 2021-06-11 - -* Breaking: - * [(link)](https://github.com/haskell-nix/hnix-store/commit/3b948d112aa9307b0451258f28c7ee5dc86b24c7) `System.Nix.Store.Remote`: - * `addToStore`: constraint of `ValidAlgo a` removed in favour of constraint on `cryptonite: HashAlgorithm a` through constraint `NamedAlgo a`. - * `queryPathFromHashPart`: 1st arg changed from `Digest StorePathHashAlgo` to `StorePathHashPart`, for details: [hnix-store-core 0.5.0.0 ChangeLog](https://hackage.haskell.org/package/hnix-store-core-0.5.0.0/changelog). - -## [0.4.3.0](https://github.com/haskell-nix/hnix-store/compare/0.4.2.0...0.4.3.0) 2021-05-30 - -Nothing (it is tandem `hnix-store-core` fix release) - -## [0.4.2.0](https://github.com/haskell-nix/hnix-store/compare/0.4.1.0...0.4.2.0) 2021-03-12 - -* Additional: - - * [(link)](https://github.com/haskell-nix/hnix-store/commit/5d03ffc43cde9448df05e84838ece70cc83b1b6c) Cabal now properly states `tasty-discover` as `build-tool-depends`. - - * [(link)](https://github.com/haskell-nix/hnix-store/commit/b5ad38573d27e0732d0fadfebd98de1f753b4f07) added explicit `hie.yml` cradle description for `cabal` to help Haskell Language Server to work with monorepo. - - * [(link)](https://github.com/haskell-nix/hnix-store/commit/cf04083aba98ad40d183d1e26251101816cc07ae) Nix dev env: removed GHC 8.6.5 support, afaik it is not even in Nixpkgs anymore. - - -## [0.4.1.0](https://github.com/haskell-nix/hnix-store/compare/0.4.0.0...0.4.1.0) 2021-01-16 - -* `System.Nix.Store.Remote`: module API now re-exports `System.Nix.Store.Remote.Types` API -* Big clean-up of dependencies. - -## [0.4.0.0](https://github.com/haskell-nix/hnix-store/compare/0.3.0.0...0.4.0.0) 2020-12-30 - -* `hnix-store-core` compatibility - -## 0.3.0.0 -- 2020-11-29 - -* Restored most store API functions except `addToStoreNar` -* Added `buildDerivation` - -## 0.2.0.0 -- skipped - -* `hnix-store-core` release only - -## 0.1.0.0 -- 2019-03-18 - -* First version. diff --git a/README.lhs b/README.lhs new file mode 100644 --- /dev/null +++ b/README.lhs @@ -0,0 +1,36 @@ +# hnix-store-remote + +[Nix] worker protocol implementation for interacting with remote Nix store +via `nix-daemon`. + +[Nix]: https://nixos.org/nix + +## API + +[System.Nix.Store.Remote]: ./src/System/Nix/Store/Remote.hs + +## Example + +```haskell +{-# LANGUAGE OverloadedStrings #-} + +import System.Nix.StorePath (mkStorePathName) +import System.Nix.Store.Remote + +main :: IO () +main = do + runStore $ do + syncWithGC + roots <- findRoots + + res <- case mkStorePathName "hnix-store" of + Left e -> error (show e) + Right name -> + addTextToStore + (StoreText name "Hello World!") + mempty + RepairMode_DontRepair + + pure (roots, res) + >>= print +``` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -12,17 +12,25 @@ ## Example ```haskell +{-# LANGUAGE OverloadedStrings #-} -import Control.Monad.IO.Class (liftIO) -import Data.HashSet as HS +import System.Nix.StorePath (mkStorePathName) import System.Nix.Store.Remote +main :: IO () main = do runStore $ do syncWithGC roots <- findRoots - liftIO $ print roots - res <- addTextToStore "hnix-store" "test" (HS.fromList []) False - liftIO $ print res + res <- case mkStorePathName "hnix-store" of + Left e -> error (show e) + Right name -> + addTextToStore + (StoreText name "Hello World!") + mempty + RepairMode_DontRepair + + pure (roots, res) + >>= print ``` diff --git a/app/BuildDerivation.hs b/app/BuildDerivation.hs new file mode 100644 --- /dev/null +++ b/app/BuildDerivation.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE LambdaCase #-} +module Main where + +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 + +main :: IO () +main = System.Environment.getArgs >>= \case + [filename] -> do + case System.Nix.StorePath.parsePathFromText def (Data.Text.pack filename) of + Left e -> error $ show e + Right p -> do + out <- + System.Nix.Store.Remote.runStore + $ System.Nix.Store.Remote.buildDerivation + p + System.Nix.Build.BuildMode_Normal + print out + _ -> error "No input derivation file" + diff --git a/hnix-store-remote.cabal b/hnix-store-remote.cabal --- a/hnix-store-remote.cabal +++ b/hnix-store-remote.cabal @@ -1,23 +1,51 @@ cabal-version: 2.2 name: hnix-store-remote -version: 0.6.0.0 +version: 0.7.0.0 synopsis: Remote hnix store description: Implementation of the nix store using the daemon protocol. homepage: https://github.com/haskell-nix/hnix-store license: Apache-2.0 license-file: LICENSE -author: Richard Marko +author: Sorki maintainer: srk@48.io -copyright: 2018 Richard Marko +copyright: 2018 Sorki category: Nix build-type: Simple -extra-source-files: ChangeLog.md, README.md +extra-doc-files: + CHANGELOG.md +extra-source-files: + README.md + , README.lhs -Common commons - if impl(ghc >= 8.10) - ghc-options: -Wall -Wunused-packages - else - ghc-options: -Wall +common commons + ghc-options: -Wall + default-extensions: + DataKinds + , DefaultSignatures + , DeriveGeneric + , DeriveDataTypeable + , DeriveFunctor + , DeriveFoldable + , DeriveTraversable + , DeriveLift + , DerivingVia + , FlexibleContexts + , FlexibleInstances + , GADTs + , RecordWildCards + , ScopedTypeVariables + , StandaloneDeriving + , TypeApplications + , TypeOperators + , TypeSynonymInstances + , InstanceSigs + , KindSignatures + , MultiParamTypeClasses + , TupleSections + , LambdaCase + , BangPatterns + , ViewPatterns + default-language: Haskell2010 flag io-testsuite default: @@ -26,117 +54,174 @@ Enable testsuite, which requires external binaries and Linux namespace support. +flag build-derivation + default: + False + description: + Build build-derivation executable + +flag build-readme + default: + False + description: + Build README.lhs example + library import: commons exposed-modules: - System.Nix.Store.Remote - , System.Nix.Store.Remote.Binary - , System.Nix.Store.Remote.Builders + Data.Serializer + , Data.Serializer.Example + , System.Nix.Store.Remote + , System.Nix.Store.Remote.Arbitrary + , System.Nix.Store.Remote.Client + , System.Nix.Store.Remote.Client.Core , System.Nix.Store.Remote.Logger - , System.Nix.Store.Remote.Parsers - , System.Nix.Store.Remote.Protocol + , System.Nix.Store.Remote.MonadStore + , System.Nix.Store.Remote.Serializer + , System.Nix.Store.Remote.Server + , System.Nix.Store.Remote.Socket , System.Nix.Store.Remote.Types - , System.Nix.Store.Remote.Util + , System.Nix.Store.Remote.Types.Activity + , System.Nix.Store.Remote.Types.CheckMode + , System.Nix.Store.Remote.Types.GC + , System.Nix.Store.Remote.Types.Handshake + , System.Nix.Store.Remote.Types.Logger + , System.Nix.Store.Remote.Types.NoReply + , System.Nix.Store.Remote.Types.ProtoVersion + , System.Nix.Store.Remote.Types.Query + , System.Nix.Store.Remote.Types.Query.Missing + , System.Nix.Store.Remote.Types.StoreConfig + , System.Nix.Store.Remote.Types.StoreRequest + , System.Nix.Store.Remote.Types.StoreReply + , System.Nix.Store.Remote.Types.StoreText + , System.Nix.Store.Remote.Types.SubstituteMode + , System.Nix.Store.Remote.Types.SuccessCodeReply + , System.Nix.Store.Remote.Types.TrustedFlag + , System.Nix.Store.Remote.Types.Verbosity + , System.Nix.Store.Remote.Types.WorkerMagic + , System.Nix.Store.Remote.Types.WorkerOp build-depends: base >=4.12 && <5 - , relude >= 1.0 + , hnix-store-core >= 0.8 && <0.9 + , hnix-store-json >= 0.1 + , hnix-store-nar >= 0.1 + , hnix-store-tests >= 0.1 + , aeson , attoparsec - , binary , bytestring + , cereal , containers - , cryptonite + , concurrency + , crypton + , data-default-class + , dependent-sum > 0.7 + , dependent-sum-template >= 0.2.0.1 && < 0.3 +-- , directory + , dlist >= 1.0 + , exceptions + , generic-arbitrary < 1.1 + , hashable , text , time + , transformers , network - , nix-derivation >= 1.1.1 && <2 , mtl + , QuickCheck , unordered-containers - , hnix-store-core >= 0.6 && <0.7 - mixins: - base hiding (Prelude) - , relude (Relude as Prelude) - , relude - default-extensions: - OverloadedStrings - , DeriveGeneric - , DeriveDataTypeable - , DeriveFunctor - , DeriveFoldable - , DeriveTraversable - , DeriveLift - , FlexibleContexts - , FlexibleInstances - , StandaloneDeriving - , TypeApplications - , TypeSynonymInstances - , InstanceSigs - , MultiParamTypeClasses - , TupleSections - , LambdaCase - , BangPatterns - , ViewPatterns + , unix >= 2.7 + , vector hs-source-dirs: src - default-language: Haskell2010 ghc-options: -Wall -test-suite hnix-store-remote-tests - import: commons +executable build-derivation + if !flag(build-derivation) + buildable: False + build-depends: + base >=4.12 && <5 + , hnix-store-core + , 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" - if !flag(io-testsuite) +executable remote-readme + if !flag(build-readme) buildable: False - ghc-options: -rtsopts -fprof-auto + build-depends: + base >=4.12 && <5 + , hnix-store-core + , hnix-store-remote + build-tool-depends: + markdown-unlit:markdown-unlit + default-language: Haskell2010 + main-is: README.lhs + ghc-options: -pgmL markdown-unlit -Wall +test-suite remote + import: commons type: exitcode-stdio-1.0 main-is: Driver.hs - other-modules: - NixDaemon - , Spec - , Util hs-source-dirs: tests + ghc-options: -Wall -threaded -rtsopts "-with-rtsopts -N" + other-modules: + Data.SerializerSpec + EnumSpec + NixSerializerSpec build-tool-depends: - tasty-discover:tasty-discover + hspec-discover:hspec-discover build-depends: - base - , relude - , hnix-store-core >= 0.3 + base >=4.12 && <5 + , hnix-store-core , hnix-store-remote + , hnix-store-tests + , bytestring + , crypton + , some > 1.0.5 && < 2 + , time + , hspec + , QuickCheck + +test-suite remote-io + import: commons + + if !flag(io-testsuite) || os(darwin) + buildable: False + + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: tests-io + -- See https://github.com/redneb/hs-linux-namespaces/issues/3 + ghc-options: -rtsopts -fprof-auto "-with-rtsopts -V0" + other-modules: + DataSink + , NixDaemonSpec + , SampleNar + build-depends: + base >=4.12 && <5 + , hnix-store-core + , hnix-store-nar + , hnix-store-remote + , hnix-store-tests + , bytestring + , concurrency , containers - , cryptonite + , crypton + , data-default-class + , dependent-sum , directory - , process + , exceptions , filepath - , hspec-expectations-lifted - , quickcheck-text - , tasty , hspec - , tasty-hspec - , tasty-quickcheck + , hspec-expectations-lifted , linux-namespaces + , process + , some , temporary + , text + , time , unix , unordered-containers - mixins: - base hiding (Prelude) - , relude (Relude as Prelude) - , relude - default-extensions: - OverloadedStrings - , DeriveGeneric - , DeriveDataTypeable - , DeriveFunctor - , DeriveFoldable - , DeriveTraversable - , DeriveLift - , FlexibleContexts - , FlexibleInstances - , StandaloneDeriving - , TypeApplications - , TypeSynonymInstances - , InstanceSigs - , MultiParamTypeClasses - , TupleSections - , LambdaCase - , BangPatterns - , ViewPatterns - default-language: Haskell2010 diff --git a/src/Data/Serializer.hs b/src/Data/Serializer.hs new file mode 100644 --- /dev/null +++ b/src/Data/Serializer.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-| +Description : Serializer data type +Copyright : (c) John Ericson, 2023 + Sorki, 2023 +Stability : experimental + +@Serializer@ ties @Get@ and @PutM@ monads +into a single datatype and allows +transforming both monads with a monad transformer +for adding extra layers like @ExceptT@ +(for example when @putS@ can fail due to unsupported +version of a protocol) or @ReaderT@ (when we need +to serialize a data type based differently based +on a protocol version). + +See "Data.Serializer.Example" +-} + +module Data.Serializer + ( + -- * Serializer + Serializer(..) + -- ** Runners + , runGetS + , runPutS + -- * Simple serializer + , SimpleSerializer + -- ** Simple runners + , runGetSimple + , runPutSimple + -- * From Get/Put, Serialize + , lift2 + , liftSerialize + -- * Combinators + , mapIsoSerializer + , mapPrismSerializer + , tup + -- * Utility + , GetSerializerError(..) + , transformGetError + , transformPutError + -- * Re-exports + , Get + , PutM + ) where + +#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.Trans.Identity (IdentityT, runIdentityT) +import Data.ByteString (ByteString) +import Data.Serialize (Serialize) +import Data.Serialize.Get (Get, runGet) +import Data.Serialize.Put (Putter, PutM, runPutM) + +import qualified Data.Serialize + +-- * Serializer + +-- | @Serializer@ ties @Get@ and @PutM@ monads +-- into a single datatype and allows +-- transforming the monads with a monad transformer +-- for e.g. adding @ExceptT@ or @ReaderT@ layers. +data Serializer t a = Serializer + { getS :: t Get a + , putS :: a -> t PutM () + } + +-- ** Runners + +-- | Runner for putS of @Serializer@ +runPutS + :: ( Monad (t PutM) + , MonadTrans t + ) + => Serializer t a -- ^ Serializer + -> (t PutM () -> PutM b) -- ^ Tranformer runner + -> a -- ^ Value to (out)put + -> (b, ByteString) +runPutS s run a = runPutM $ run $ (putS s) a + +-- | Runner for getS of @Serializer@ +runGetS + :: ( Monad (t Get) + , MonadTrans t + ) + => Serializer t a -- ^ Serializer + -> (t Get a -> Get b) -- ^ Tranformer runner + -> ByteString -- ^ ByteString to parse + -> Either String b +runGetS s run b = runGet (run (getS s)) b + +-- * Simple serializer + +-- | Simple @Serializer@ +type SimpleSerializer a = Serializer IdentityT a + +-- ** Simple runners + +-- | Runner for getS of @SimpleSerializer@ +runGetSimple + :: SimpleSerializer a + -> ByteString + -> Either String a +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@ +lift2 + :: forall a t + . MonadTrans t + => Get a + -> Putter a + -> Serializer t a +lift2 f g = Serializer + { getS = lift f + , putS = lift . g + } + +-- | Lift @Serialize a@ instance into @Serializer@ +liftSerialize + :: ( Serialize a + , MonadTrans t + ) + => Serializer t a +liftSerialize = + lift2 + Data.Serialize.get + Data.Serialize.put + +-- * Combinators + +-- | Map over @Serializer@ +mapIsoSerializer + :: Functor (t Get) + => (a -> b) -- ^ Map over @getS@ + -> (b -> a) -- ^ Map over @putS@ + -> Serializer t a + -> Serializer t b +mapIsoSerializer f g s = Serializer + { getS = f <$> getS s + , putS = putS s . g + } + +-- | 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@ + -> Serializer t a + -> Serializer t b +mapPrismSerializer f g s = Serializer + { getS = either throwError pure . f =<< getS s + , putS = putS s . g + } + +-- | Tuple combinator +tup + :: ( Applicative (t Get) + , Monad (t PutM) + ) + => Serializer t a + -> Serializer t b + -> Serializer t (a, b) +tup a b = Serializer + { getS = liftA2 (,) (getS a) (getS b) + , putS = \(x, y) -> do + putS a x + putS b y + } + +-- * Utilities + +-- | Wrapper for both GetS errors +-- +-- * the one that occurs when @fail@ is called +-- * custom one when @ExceptT@ is used +data GetSerializerError customGetError + = SerializerError_GetFail String + | SerializerError_Get customGetError + deriving (Eq, Ord, Show) + +-- | Helper for transforming nested Eithers +-- into @GetSerializerError@ wrapper +transformGetError + :: Either String (Either customGetError b) + -> Either (GetSerializerError customGetError) b +transformGetError = \case + 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 new file mode 100644 --- /dev/null +++ b/src/Data/Serializer/Example.hs @@ -0,0 +1,329 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Data.Serializer.Example + ( + -- * Simple protocol + OpCode(..) + , Cmd(..) + -- * Cmd Serializer + , cmdS + -- * Runners + , runG + , 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 + , runPRest + ) where + +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.Reader (MonadReader, ask) +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.ByteString (ByteString) +import Data.Int (Int8) +import Data.GADT.Show (GShow(..), defaultGshowsPrec) +import Data.Kind (Type) +import Data.Type.Equality (TestEquality(..), (:~:)(Refl)) +import Data.Serialize.Get (Get, getInt8) +import Data.Serialize.Put (Putter, PutM, putInt8) +import Data.Serializer + ( Serializer(..) + , GetSerializerError + , runGetS + , runPutS + , transformGetError + , transformPutError + ) +import Data.Some (Some(..)) +import GHC.Generics (Generic) + +import Test.QuickCheck (Arbitrary(..), oneof) + +-- * Simple protocol + +-- | OpCode used to differentiate between operations +data OpCode = OpCode_Int | OpCode_Bool + deriving (Bounded, Eq, Enum, Generic, Ord, Show) + +-- | Protocol operations +data Cmd :: Type -> Type where + Cmd_Int :: Int8 -> Cmd Int8 + Cmd_Bool :: Bool -> Cmd Bool + +deriving instance Eq (Cmd a) +deriving instance Show (Cmd a) + +instance GShow Cmd where + gshowsPrec = defaultGshowsPrec + +instance TestEquality Cmd where + testEquality (Cmd_Int _) (Cmd_Int _) = Just Refl + testEquality (Cmd_Bool _) (Cmd_Bool _) = Just Refl + testEquality _ _ = Nothing + +-- constructors only +-- import Data.GADT.Compare +-- instance GEq Cmd where +-- geq = testEquality + +instance {-# OVERLAPPING #-} Eq (Some Cmd) where + Some (Cmd_Int a) == Some (Cmd_Int b) = a == b + Some (Cmd_Bool a) == Some (Cmd_Bool b) = a == b + _ == _ = False + +instance Arbitrary (Some Cmd) where + arbitrary = oneof + [ Some . Cmd_Int <$> arbitrary + , Some . Cmd_Bool <$> arbitrary + ] + +-- | @OpCode@ @Serializer@ +opcode :: MonadTrans t => Serializer t OpCode +opcode = Serializer + { getS = lift getEnum + , putS = lift . putEnum + } + +-- * Cmd Serializer + +-- | @Cmd@ @Serializer@ +cmdS + :: forall t . ( MonadTrans t + , Monad (t Get) + , Monad (t PutM) + ) + => 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) + } + +-- * Runners + +-- | @runGetS@ specialized to @ExceptT e@ +runG + :: Serializer (ExceptT e) a + -> ByteString + -> Either (GetSerializerError e) a +runG s = + transformGetError + . runGetS s runExceptT + +-- | @runPutS@ specialized to @ExceptT e@ +runP + :: Serializer (ExceptT e) a + -> a + -> Either e ByteString +runP s = + (\(e, r) -> either Left (pure $ Right r) e) + . runPutS s runExceptT + +-- * Custom errors + +data MyGetError + = 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) +cmdSGetError = Serializer + { getS = getS opcode >>= \case + OpCode_Int -> Some . Cmd_Int <$> lift getInt8 + OpCode_Bool -> throwError MyGetError_Example + , putS = putS cmdS + } + +-- *** getS with fail + +cmdSGetFail + :: ( MonadTrans t + , MonadFail (t Get) + , Monad (t PutM) + ) + => Serializer t (Some Cmd) +cmdSGetFail = Serializer + { 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" + } + +-- * Elaborate + +-- | Transformer for @Serializer@ +newtype REST r e s m a = REST + { _unREST :: ExceptT e (StateT s (ReaderT r m)) a } + deriving + ( Applicative + , Functor + , Monad + , MonadError e + , MonadReader r + , MonadState s + , MonadFail + ) + +instance MonadTrans (REST r e s) where + lift = REST . lift . lift . lift + +-- | Runner for @REST@ +restRunner + :: Monad m + => r + -> s + -> REST r e s m a + -> m ((Either e a), s) +restRunner r s = + (`runReaderT` r) + . (`runStateT` s) + . runExceptT + . _unREST + +runGRest + :: Serializer (REST r e s) a + -> r + -> s + -> ByteString + -> Either (GetSerializerError e) a +runGRest serializer r s = + transformGetError + . second fst + . runGetS + serializer + (restRunner r s) + +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) + +cmdSRest + :: Serializer (REST Bool e Int) (Some Cmd) +cmdSRest = 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 + if isTrue + then lift (putInt8 (i - 1)) + else lift (putInt8 i) + Some (Cmd_Bool b) -> putS opcode OpCode_Bool >> lift (putBool b) + } + +-- Primitives helpers + +getInt :: Integral a => Get a +getInt = fromIntegral <$> getInt8 + +putInt :: Integral a => Putter a +putInt = putInt8 . fromIntegral + +-- | Deserialize @Bool@ from integer +getBool :: Get Bool +getBool = (getInt :: Get Int8) >>= \case + 0 -> pure False + 1 -> pure True + x -> fail $ "illegal bool value " ++ show x + +-- | Serialize @Bool@ into integer +putBool :: Putter Bool +putBool True = putInt (1 :: Int8) +putBool False = putInt (0 :: Int8) + +-- | Utility toEnum version checking bounds using Bounded class +toEnumCheckBounds + :: forall a + . ( Bounded a + , Enum a + ) + => Int + -> Either String a +toEnumCheckBounds = \case + x | x < fromEnum (minBound @a) -> Left $ "enum out of min bound " ++ show x + x | x > fromEnum (maxBound @a) -> Left $ "enum out of max bound " ++ show x + x | otherwise -> Right $ toEnum x + +-- | Deserialize @Enum@ to integer +getEnum + :: ( Bounded a + , Enum a + ) + => Get a +getEnum = + toEnumCheckBounds <$> getInt + >>= either fail pure + +-- | Serialize @Enum@ to integer +putEnum :: Enum a => Putter a +putEnum = putInt . fromEnum 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 @@ -1,309 +1,199 @@ -{-# language AllowAmbiguousTypes #-} -{-# language KindSignatures #-} -{-# language RankNTypes #-} -{-# language ScopedTypeVariables #-} -{-# language DataKinds #-} -{-# language RecordWildCards #-} -{-# language LiberalTypeSynonyms #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} module System.Nix.Store.Remote - ( addToStore - , addTextToStore - , addSignatures - , addIndirectRoot - , addTempRoot - , buildPaths - , buildDerivation - , ensurePath - , findRoots - , isValidPathUncached - , queryValidPaths - , queryAllValidPaths - , querySubstitutablePaths - , queryPathInfoUncached - , queryReferrers - , queryValidDerivers - , queryDerivationOutputs - , queryDerivationOutputNames - , queryPathFromHashPart - , queryMissing - , optimiseStore - , runStore - , syncWithGC - , verifyStore + ( module System.Nix.Store.Types + , module System.Nix.Store.Remote.Client + , module System.Nix.Store.Remote.MonadStore , module System.Nix.Store.Remote.Types - ) -where - -import Prelude hiding ( putText ) -import qualified Data.ByteString.Lazy as BSL + -- * Compat + , MonadStore + -- * Runners + , runStore + , runStoreConnection + , runStoreSocket + -- ** Daemon + , runDaemon + , runDaemonConnection + , justdoit + ) where -import Nix.Derivation ( Derivation ) -import System.Nix.Build ( BuildMode - , BuildResult - ) -import System.Nix.Hash ( NamedAlgo(..) - , SomeNamedDigest(..) - , BaseEncoding(NixBase32) - , decodeDigestWith - ) -import System.Nix.StorePath ( StorePath - , StorePathName - , StorePathSet - , StorePathHashPart - ) -import System.Nix.StorePathMetadata ( StorePathMetadata(..) - , StorePathTrust(..) - ) -import System.Nix.Internal.Base ( encodeWith ) +import Control.Monad.Catch (MonadMask) +import Control.Monad.Conc.Class (MonadConc) +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.Remote.MonadStore + ( runRemoteStoreT + , MonadRemoteStore(..) + , RemoteStoreT + , RemoteStoreError(RemoteStoreError_GetAddrInfoFailed)) +import System.Nix.Store.Remote.Client +import System.Nix.Store.Remote.Server (WorkerHelper, runProxyDaemon) +import System.Nix.Store.Remote.Types -import qualified Data.Binary.Put -import qualified Data.Map.Strict -import qualified Data.Set +import qualified Control.Monad.Catch +import qualified Network.Socket +-- see TODO bellow +--import qualified System.Directory +-- wip justdoit +import System.Nix.StorePath (StorePath) import qualified System.Nix.StorePath -import qualified System.Nix.Store.Remote.Parsers -import System.Nix.Store.Remote.Binary -import System.Nix.Store.Remote.Types -import System.Nix.Store.Remote.Protocol -import System.Nix.Store.Remote.Util -import Crypto.Hash ( SHA256 ) -import System.Nix.Nar ( NarSource ) - -type RepairFlag = Bool -type CheckFlag = Bool -type SubstituteFlag = Bool - --- | Pack `Nar` and add it to the store. -addToStore - :: forall a - . (NamedAlgo a) - => StorePathName -- ^ Name part of the newly created `StorePath` - -> NarSource MonadStore -- ^ provide nar stream - -> Bool -- ^ Add target directory recursively - -> RepairFlag -- ^ Only used by local store backend - -> MonadStore StorePath -addToStore name source recursive _repair = do - runOpArgsIO AddToStore $ \yield -> do - yield $ toStrict $ Data.Binary.Put.runPut $ do - putText $ System.Nix.StorePath.unStorePathName name - putBool $ not $ System.Nix.Hash.algoName @a == "sha256" && recursive - putBool recursive - putText $ System.Nix.Hash.algoName @a - source yield - sockGetPath - --- | Add text to store. --- --- Reference accepts repair but only uses it --- to throw error in case of remote talking to nix-daemon. -addTextToStore - :: Text -- ^ Name of the text - -> Text -- ^ Actual text to add - -> StorePathSet -- ^ Set of `StorePath`s that the added text references - -> RepairFlag -- ^ Repair flag, must be `False` in case of remote backend - -> MonadStore StorePath -addTextToStore name text references' repair = do - when repair - $ error "repairing is not supported when building through the Nix daemon" - runOpArgs AddTextToStore $ do - putText name - putText text - putPaths references' - sockGetPath - -addSignatures :: StorePath -> [BSL.ByteString] -> MonadStore () -addSignatures p signatures = do - void $ simpleOpArgs AddSignatures $ do - putPath p - putByteStrings signatures - -addIndirectRoot :: StorePath -> MonadStore () -addIndirectRoot pn = do - void $ simpleOpArgs AddIndirectRoot $ putPath pn - --- | Add temporary garbage collector root. --- --- This root is removed as soon as the client exits. -addTempRoot :: StorePath -> MonadStore () -addTempRoot pn = do - void $ simpleOpArgs AddTempRoot $ putPath pn - --- | Build paths if they are an actual derivations. --- --- If derivation output paths are already valid, do nothing. -buildPaths :: StorePathSet -> BuildMode -> MonadStore () -buildPaths ps bm = do - void $ simpleOpArgs BuildPaths $ do - putPaths ps - putInt $ fromEnum bm - -buildDerivation - :: StorePath - -> Derivation StorePath Text - -> BuildMode - -> MonadStore BuildResult -buildDerivation p drv buildMode = do - runOpArgs BuildDerivation $ do - putPath p - putDerivation drv - putEnum buildMode - -- XXX: reason for this is unknown - -- but without it protocol just hangs waiting for - -- more data. Needs investigation. - -- Intentionally the only warning that should pop-up. - putInt (0 :: Integer) - - getSocketIncremental getBuildResult - -ensurePath :: StorePath -> MonadStore () -ensurePath pn = do - void $ simpleOpArgs EnsurePath $ putPath pn - --- | Find garbage collector roots. -findRoots :: MonadStore (Map BSL.ByteString StorePath) -findRoots = do - runOp FindRoots - sd <- getStoreDir - res <- - getSocketIncremental - $ getMany - $ (,) - <$> (fromStrict <$> getByteStringLen) - <*> getPath sd - - r <- catRights res - pure $ Data.Map.Strict.fromList r - where - catRights :: [(a, Either String b)] -> MonadStore [(a, b)] - catRights = mapM ex - - ex :: (a, Either [Char] b) -> MonadStore (a, b) - ex (x , Right y) = pure (x, y) - ex (_x, Left e ) = error $ "Unable to decode root: " <> fromString e - -isValidPathUncached :: StorePath -> MonadStore Bool -isValidPathUncached p = do - simpleOpArgs IsValidPath $ putPath p - --- | Query valid paths from set, optionally try to use substitutes. -queryValidPaths - :: StorePathSet -- ^ Set of `StorePath`s to query - -> SubstituteFlag -- ^ Try substituting missing paths when `True` - -> MonadStore StorePathSet -queryValidPaths ps substitute = do - runOpArgs QueryValidPaths $ do - putPaths ps - putBool substitute - sockGetPaths - -queryAllValidPaths :: MonadStore StorePathSet -queryAllValidPaths = do - runOp QueryAllValidPaths - sockGetPaths - -querySubstitutablePaths :: StorePathSet -> MonadStore StorePathSet -querySubstitutablePaths ps = do - runOpArgs QuerySubstitutablePaths $ putPaths ps - sockGetPaths - -queryPathInfoUncached :: StorePath -> MonadStore StorePathMetadata -queryPathInfoUncached path = do - runOpArgs QueryPathInfo $ do - putPath path - - valid <- sockGetBool - unless valid $ error "Path is not valid" - - deriverPath <- sockGetPathMay - - narHashText <- decodeUtf8 <$> sockGetStr - let - narHash = - case - decodeDigestWith @SHA256 NixBase32 narHashText - of - Left e -> error $ fromString e - Right x -> SomeDigest x - - references <- sockGetPaths - registrationTime <- sockGet getTime - narBytes <- Just <$> sockGetInt - ultimate <- sockGetBool - - _sigStrings <- fmap bsToText <$> sockGetStrings - caString <- sockGetStr - - let - -- XXX: signatures need pubkey from config - sigs = Data.Set.empty - - contentAddressableAddress = - case - System.Nix.Store.Remote.Parsers.parseContentAddressableAddress caString - of - Left e -> error $ fromString e - Right x -> Just x - - trust = if ultimate then BuiltLocally else BuiltElsewhere +-- * Compat - pure $ StorePathMetadata{..} +type MonadStore = RemoteStoreT IO -queryReferrers :: StorePath -> MonadStore StorePathSet -queryReferrers p = do - runOpArgs QueryReferrers $ putPath p - sockGetPaths +-- * Runners -queryValidDerivers :: StorePath -> MonadStore StorePathSet -queryValidDerivers p = do - runOpArgs QueryValidDerivers $ putPath p - sockGetPaths +runStore + :: ( MonadIO m + , MonadMask m + ) + => RemoteStoreT m a + -> Run m a +runStore = runStoreConnection def -queryDerivationOutputs :: StorePath -> MonadStore StorePathSet -queryDerivationOutputs p = do - runOpArgs QueryDerivationOutputs $ putPath p - sockGetPaths +runStoreConnection + :: ( MonadIO m + , MonadMask m + ) + => StoreConnection + -> RemoteStoreT m a + -> Run m a +runStoreConnection sc k = + connectionToSocket sc + >>= \case + Left e -> pure (Left e, mempty) + Right (fam, sock) -> runStoreSocket fam sock k -queryDerivationOutputNames :: StorePath -> MonadStore StorePathSet -queryDerivationOutputNames p = do - runOpArgs QueryDerivationOutputNames $ putPath p - sockGetPaths +runStoreSocket + :: ( MonadIO m + , MonadMask m + ) + => Family + -> SockAddr + -> RemoteStoreT m a + -> Run m a +runStoreSocket sockFamily sockAddr code = + Control.Monad.Catch.bracket + (liftIO open) + (liftIO . Network.Socket.close . hasStoreSocket) + (\s -> runRemoteStoreT s $ greetServer >> code) + where + open = do + soc <- + Network.Socket.socket + sockFamily + Network.Socket.Stream + Network.Socket.defaultProtocol + Network.Socket.connect soc sockAddr + pure soc -queryPathFromHashPart :: StorePathHashPart -> MonadStore StorePath -queryPathFromHashPart storePathHash = do - runOpArgs QueryPathFromHashPart - $ putByteStringLen - $ encodeUtf8 (encodeWith NixBase32 $ coerce storePathHash) - sockGetPath +justdoit :: Run IO (Bool, Bool) +justdoit = do + runDaemonConnection runStore (pure ()) (StoreConnection_Socket "/tmp/dsock") $ + runStoreConnection (StoreConnection_Socket "/tmp/dsock") + $ do + a <- isValidPath pth + b <- isValidPath pth + pure (a, b) + where + pth :: StorePath + pth = + either (error . show) id + $ System.Nix.StorePath.parsePathFromText + def + "/nix/store/yyznqbwam67cmp7zfwk0rkgmi9yqsdsm-hnix-store-core-0.8.0.0" -queryMissing - :: StorePathSet - -> MonadStore - ( StorePathSet-- Paths that will be built - , StorePathSet -- Paths that have substitutes - , StorePathSet -- Unknown paths - , Integer -- Download size - , Integer -- Nar size? - ) -queryMissing ps = do - runOpArgs QueryMissing $ putPaths ps +runDaemon + :: forall m a + . ( MonadIO m + , MonadConc m + ) + => WorkerHelper m + -> m a + -> m a +runDaemon workerHelper = + runDaemonConnection + workerHelper + (pure ()) + def - willBuild <- sockGetPaths - willSubstitute <- sockGetPaths - unknown <- sockGetPaths - downloadSize' <- sockGetInt - narSize' <- sockGetInt - pure (willBuild, willSubstitute, unknown, downloadSize', narSize') +-- | Run an emulated nix daemon using given @StoreConnection@ +-- the deamon will close when the continuation returns. +runDaemonConnection + :: forall m a + . ( MonadIO m + , MonadConc m + ) + => WorkerHelper m + -> RemoteStoreT m () + -> StoreConnection + -> m a + -> m a +runDaemonConnection workerHelper postGreet sc k = + connectionToSocket sc + >>= \case + Left e -> error $ show e + Right (fam, sock) -> runDaemonSocket workerHelper postGreet fam sock k -optimiseStore :: MonadStore () -optimiseStore = void $ simpleOp OptimiseStore +-- | Run an emulated nix daemon using given @StoreConnection@ +-- the deamon will close when the continuation returns. +runDaemonSocket + :: forall m a + . ( MonadIO m + , MonadConc m + ) + => WorkerHelper m + -> RemoteStoreT m () + -> Family + -> SockAddr + -> m a + -> m a +runDaemonSocket workerHelper postGreet sockFamily sockAddr k = + Control.Monad.Catch.bracket + (liftIO + $ Network.Socket.socket + sockFamily + Network.Socket.Stream + Network.Socket.defaultProtocol + ) + (\lsock -> liftIO $ Network.Socket.close lsock) + $ \lsock -> do + -- TODO: the: (\lsock -> liftIO $ Network.Socket.close lsock *> System.Directory.removeFile f) + -- branch should really be (and even removeFile is currently omitted) + -- a file lock followed by unlink *before* bind rather than after close. If + -- the program crashes (or loses power or something) then a stale unix + -- socket will stick around and prevent the daemon from starting. using a + -- lock file instead means only one "copy" of the daemon can hold the lock, + -- and can safely unlink the socket before binding no matter how shutdown + -- occured. -syncWithGC :: MonadStore () -syncWithGC = void $ simpleOp SyncWithGC + -- set up the listening socket + liftIO $ Network.Socket.bind lsock sockAddr + runProxyDaemon workerHelper postGreet lsock k --- returns True on errors -verifyStore :: CheckFlag -> RepairFlag -> MonadStore Bool -verifyStore check repair = simpleOpArgs VerifyStore $ do - putBool check - putBool repair +connectionToSocket + :: MonadIO m + => StoreConnection + -> m (Either RemoteStoreError (Family, SockAddr)) +connectionToSocket (StoreConnection_Socket (StoreSocketPath f)) = + pure $ pure + ( Network.Socket.AF_UNIX + , SockAddrUnix f + ) +connectionToSocket (StoreConnection_TCP StoreTCP{..}) = do + addrInfo <- liftIO $ Network.Socket.getAddrInfo + (Just Network.Socket.defaultHints) + (Just storeTCPHost) + (Just $ show storeTCPPort) + case addrInfo of + (sockAddr:_) -> + pure $ pure + ( Network.Socket.addrFamily sockAddr + , Network.Socket.addrAddress sockAddr + ) + _ -> pure (Left RemoteStoreError_GetAddrInfoFailed) diff --git a/src/System/Nix/Store/Remote/Arbitrary.hs b/src/System/Nix/Store/Remote/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Arbitrary.hs @@ -0,0 +1,137 @@ +-- due to recent generic-arbitrary +{-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module System.Nix.Store.Remote.Arbitrary where + +import Data.Some (Some(Some)) +import System.Nix.Arbitrary () +import System.Nix.Store.Types (RepairMode(..)) +import System.Nix.Store.Remote.Types + +import Test.QuickCheck (Arbitrary(..), oneof, suchThat) +import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..)) + +deriving via GenericArbitrary CheckMode + instance Arbitrary CheckMode + +deriving via GenericArbitrary SubstituteMode + instance Arbitrary SubstituteMode + +deriving via GenericArbitrary ProtoStoreConfig + instance Arbitrary ProtoStoreConfig + +deriving via GenericArbitrary ProtoVersion + instance Arbitrary ProtoVersion + +deriving via GenericArbitrary StoreText + instance Arbitrary StoreText + +-- * Logger + +deriving via GenericArbitrary Activity + instance Arbitrary Activity + +deriving via GenericArbitrary ActivityID + instance Arbitrary ActivityID + +deriving via GenericArbitrary ActivityResult + instance Arbitrary ActivityResult + +deriving via GenericArbitrary Field + instance Arbitrary Field + +instance Arbitrary Trace where + arbitrary = do + -- we encode 0 position as Nothing + tracePosition <- arbitrary `suchThat` (/= Just 0) + traceHint <- arbitrary + + pure Trace{..} + +deriving via GenericArbitrary BasicError + instance Arbitrary BasicError + +instance Arbitrary ErrorInfo where + arbitrary = do + errorInfoLevel <- arbitrary + errorInfoMessage <- arbitrary + -- we encode 0 position as Nothing + errorInfoPosition <- arbitrary `suchThat` (/= Just 0) + errorInfoTraces <- arbitrary + + pure ErrorInfo{..} + +deriving via GenericArbitrary LoggerOpCode + instance Arbitrary LoggerOpCode + +deriving via GenericArbitrary Logger + instance Arbitrary Logger + +deriving via GenericArbitrary Verbosity + instance Arbitrary Verbosity + +-- * GC + +deriving via GenericArbitrary GCAction + instance Arbitrary GCAction + +deriving via GenericArbitrary GCOptions + instance Arbitrary GCOptions + +-- * Handshake + +deriving via GenericArbitrary WorkerMagic + instance Arbitrary WorkerMagic + +deriving via GenericArbitrary TrustedFlag + instance Arbitrary TrustedFlag + +-- * Worker protocol + +deriving via GenericArbitrary WorkerOp + instance Arbitrary WorkerOp + +-- ** Request + +instance Arbitrary (Some StoreRequest) where + arbitrary = oneof + [ Some <$> (AddToStore <$> arbitrary <*> arbitrary <*> arbitrary <*> pure RepairMode_DontRepair) + , 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) + , Some . CollectGarbage <$> arbitrary + , Some . EnsurePath <$> arbitrary + , pure $ Some FindRoots + , Some . IsValidPath <$> arbitrary + , Some . NarFromPath <$> arbitrary + , Some <$> (QueryValidPaths <$> arbitrary <*> arbitrary) + , pure $ Some QueryAllValidPaths + , Some . QuerySubstitutablePaths <$> arbitrary + , Some . QueryPathInfo <$> arbitrary + , Some . QueryReferrers <$> arbitrary + , Some . QueryValidDerivers <$> arbitrary + , Some . QueryDerivationOutputs <$> arbitrary + , Some . QueryDerivationOutputNames <$> arbitrary + , Some . QueryPathFromHashPart <$> arbitrary + , Some . QueryMissing <$> arbitrary + , pure $ Some OptimiseStore + , pure $ Some SyncWithGC + , Some <$> (VerifyStore <$> arbitrary <*> arbitrary) + ] + +-- ** Reply + +deriving via GenericArbitrary SuccessCodeReply + instance Arbitrary SuccessCodeReply + +deriving via GenericArbitrary GCResult + instance Arbitrary GCResult + +deriving via GenericArbitrary GCRoot + instance Arbitrary GCRoot + +deriving via GenericArbitrary Missing + instance Arbitrary Missing diff --git a/src/System/Nix/Store/Remote/Binary.hs b/src/System/Nix/Store/Remote/Binary.hs deleted file mode 100644 --- a/src/System/Nix/Store/Remote/Binary.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-| -Description : Utilities for packing stuff -Maintainer : srk -|-} -module System.Nix.Store.Remote.Binary where - -import Data.Binary.Get -import Data.Binary.Put -import qualified Data.ByteString.Lazy as BSL - -putInt :: Integral a => a -> Put -putInt = putWord64le . fromIntegral - -getInt :: Integral a => Get a -getInt = fromIntegral <$> getWord64le - -putMany :: Foldable t => (a -> Put) -> t a -> Put -putMany printer xs = do - putInt (length xs) - mapM_ printer xs - -getMany :: Get a -> Get [a] -getMany parser = do - count <- getInt - replicateM count parser - --- length prefixed string packing with padding to 8 bytes -putByteStringLen :: BSL.ByteString -> Put -putByteStringLen x = do - putInt len - putLazyByteString x - when (len `mod` 8 /= 0) $ pad $ 8 - (len `mod` 8) - where - len :: Int - len = fromIntegral $ BSL.length x - pad count = replicateM_ count (putWord8 0) - -putByteStrings :: Foldable t => t BSL.ByteString -> Put -putByteStrings = putMany putByteStringLen - -getByteStringLen :: Get ByteString -getByteStringLen = do - len <- getInt - st <- getLazyByteString len - when (len `mod` 8 /= 0) $ do - pads <- unpad $ fromIntegral $ 8 - (len `mod` 8) - unless (all (== 0) pads) $ fail $ "No zeroes" <> show (st, len, pads) - pure $ toStrict st - where unpad x = replicateM x getWord8 - -getByteStrings :: Get [ByteString] -getByteStrings = getMany getByteStringLen diff --git a/src/System/Nix/Store/Remote/Builders.hs b/src/System/Nix/Store/Remote/Builders.hs deleted file mode 100644 --- a/src/System/Nix/Store/Remote/Builders.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# language AllowAmbiguousTypes #-} -{-# language ScopedTypeVariables #-} -{-# language RankNTypes #-} - -module System.Nix.Store.Remote.Builders - ( buildContentAddressableAddress - ) -where - -import qualified Data.Text.Lazy as TL -import Crypto.Hash ( Digest ) -import System.Nix.StorePath ( ContentAddressableAddress(..) - ) - -import Data.Text.Lazy.Builder ( Builder ) -import qualified Data.Text.Lazy.Builder as TL - -import System.Nix.Hash - --- | Marshall `ContentAddressableAddress` to `Text` --- in form suitable for remote protocol usage. -buildContentAddressableAddress :: ContentAddressableAddress -> TL.Text -buildContentAddressableAddress = - TL.toLazyText . contentAddressableAddressBuilder - -contentAddressableAddressBuilder :: ContentAddressableAddress -> Builder -contentAddressableAddressBuilder (Text digest) = - "text:" <> digestBuilder digest -contentAddressableAddressBuilder (Fixed _narHashMode (SomeDigest (digest :: Digest hashAlgo))) = - "fixed:" - <> TL.fromText (System.Nix.Hash.algoName @hashAlgo) - <> digestBuilder digest - -digestBuilder :: Digest a -> Builder -digestBuilder = - TL.fromText . encodeDigestWith NixBase32 diff --git a/src/System/Nix/Store/Remote/Client.hs b/src/System/Nix/Store/Remote/Client.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Client.hs @@ -0,0 +1,279 @@ +module System.Nix.Store.Remote.Client + ( addToStore + , addToStoreNar + , addTextToStore + , addSignatures + , addTempRoot + , addIndirectRoot + , buildPaths + , buildDerivation + , collectGarbage + , ensurePath + , findRoots + , isValidPath + , narFromPath + , queryValidPaths + , queryAllValidPaths + , querySubstitutablePaths + , queryPathInfo + , queryReferrers + , queryValidDerivers + , queryDerivationOutputs + , queryDerivationOutputNames + , queryPathFromHashPart + , queryMissing + , optimiseStore + , syncWithGC + , verifyStore + , module System.Nix.Store.Remote.Client.Core + ) where + +import Control.Monad (void, when) +import Control.Monad.Except (throwError) +import Data.ByteString (ByteString) +import Data.HashSet (HashSet) +import Data.Map (Map) +import Data.Set (Set) +import Data.Some (Some) +import Data.Word (Word64) + +import System.Nix.Build (BuildMode, BuildResult) +import System.Nix.DerivedPath (DerivedPath) +import System.Nix.Hash (HashAlgo(..)) +import System.Nix.Nar (NarSource) +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.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 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 + +-- | 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 + -> m StorePath +addToStore name source method hashAlgo repair = do + Control.Monad.when + (repair == RepairMode_DoRepair) + $ throwError RemoteStoreError_RapairNotSupportedByRemoteStore + + setNarSource source + doReq (AddToStore name method hashAlgo repair) + +addToStoreNar + :: MonadRemoteStore m + => StorePath + -> Metadata StorePath + -> RepairMode + -> CheckMode + -> (Word64 -> IO(Maybe ByteString)) + -> m () +addToStoreNar path metadata repair checkSigs source = do + setDataSource source + void $ doReq (AddToStoreNar path metadata repair checkSigs) + pure () + +-- | Add @StoreText@ to the store +-- Reference accepts repair but only uses it +-- to throw error in case of remote talking to nix-daemon. +addTextToStore + :: MonadRemoteStore m + => StoreText + -> HashSet StorePath -- ^ Set of `StorePath`s that the added text references + -> RepairMode -- ^ Repair mode, must be `RepairMode_DontRepair` for remote backend + -- (only valid for local store) + -> m StorePath +addTextToStore stext references repair = do + Control.Monad.when + (repair == RepairMode_DoRepair) + $ throwError RemoteStoreError_RapairNotSupportedByRemoteStore + + doReq (AddTextToStore stext references repair) + +-- | Add @Signature@s to a store path +addSignatures + :: MonadRemoteStore m + => StorePath + -> Set Signature + -> m () +addSignatures p signatures = (void . doReq) (AddSignatures p signatures) + +-- | Add temporary garbage collector root. +-- +-- This root is removed as soon as the client exits. +addTempRoot + :: MonadRemoteStore m + => StorePath + -> m () +addTempRoot = void . doReq . AddTempRoot + +-- | Add indirect garbage collector root. +addIndirectRoot + :: MonadRemoteStore m + => StorePath + -> m () +addIndirectRoot = void . doReq . AddIndirectRoot + +-- | Build a derivation available at @StorePath@ +buildDerivation + :: MonadRemoteStore m + => StorePath + -> BuildMode + -> m BuildResult +buildDerivation sp mode = do + sd <- getStoreDir + drvContents <- + Control.Monad.IO.Class.liftIO + $ Data.Text.IO.readFile + $ System.Nix.StorePath.storePathToFilePath sd sp + case Data.Attoparsec.Text.parseOnly + (System.Nix.Derivation.parseDerivation sd) drvContents of + Left e -> throwError $ RemoteStoreError_DerivationParse e + Right drv -> doReq (BuildDerivation sp drv mode) + +-- | Build paths if they are an actual derivations. +-- +-- If derivation output paths are already valid, do nothing. +buildPaths + :: MonadRemoteStore m + => Set DerivedPath + -> BuildMode + -> m () +buildPaths a b = (void . doReq) (BuildPaths a b) + +collectGarbage + :: MonadRemoteStore m + => GCOptions + -> m GCResult +collectGarbage = doReq . CollectGarbage + +ensurePath + :: MonadRemoteStore m + => StorePath + -> m () +ensurePath = void . doReq . EnsurePath + +-- | Find garbage collector roots. +findRoots + :: MonadRemoteStore m + => m (Map GCRoot StorePath) +findRoots = doReq FindRoots + +isValidPath + :: MonadRemoteStore m + => StorePath + -> m Bool +isValidPath = doReq . IsValidPath + +-- | Download a NAR file. +narFromPath + :: MonadRemoteStore m + => StorePath -- ^ Path to generate a NAR for + -> Word64 -- ^ Byte length of NAR + -> (ByteString -> IO()) -- ^ Data sink where NAR bytes will be written + -> m () +narFromPath path narSize sink = do + setDataSink sink + setDataSinkSize narSize + void $ doReq (NarFromPath path) + +-- | Query valid paths from a set, +-- optionally try to use substitutes +queryValidPaths + :: MonadRemoteStore m + => HashSet StorePath + -- ^ Set of @StorePath@s to query + -> SubstituteMode + -- ^ Try substituting missing paths when @SubstituteMode_DoSubstitute@ + -> m (HashSet StorePath) +queryValidPaths a b = doReq (QueryValidPaths a b) + +-- | Query all valid paths +queryAllValidPaths + :: MonadRemoteStore m + => m (HashSet StorePath) +queryAllValidPaths = doReq QueryAllValidPaths + +-- | Query a set of paths substituable from caches +querySubstitutablePaths + :: MonadRemoteStore m + => HashSet StorePath + -> m (HashSet StorePath) +querySubstitutablePaths = doReq . QuerySubstitutablePaths + +-- | Query path metadata +queryPathInfo + :: MonadRemoteStore m + => StorePath + -> m (Maybe (Metadata StorePath)) +queryPathInfo = doReq . QueryPathInfo + +queryReferrers + :: MonadRemoteStore m + => StorePath + -> m (HashSet StorePath) +queryReferrers = doReq . QueryReferrers + +queryValidDerivers + :: MonadRemoteStore m + => StorePath + -> m (HashSet StorePath) +queryValidDerivers = doReq . QueryValidDerivers + +queryDerivationOutputs + :: MonadRemoteStore m + => StorePath + -> m (HashSet StorePath) +queryDerivationOutputs = doReq . QueryDerivationOutputs + +queryDerivationOutputNames + :: MonadRemoteStore m + => StorePath + -> m (HashSet StorePathName) +queryDerivationOutputNames = doReq . QueryDerivationOutputNames + +queryPathFromHashPart + :: MonadRemoteStore m + => StorePathHashPart + -> m StorePath +queryPathFromHashPart = doReq . QueryPathFromHashPart + +queryMissing + :: MonadRemoteStore m + => Set DerivedPath + -> m Missing +queryMissing = doReq . QueryMissing + +optimiseStore + :: MonadRemoteStore m + => m () +optimiseStore = (void . doReq) OptimiseStore + +syncWithGC + :: MonadRemoteStore m + => m () +syncWithGC = (void . doReq) SyncWithGC + +verifyStore + :: MonadRemoteStore m + => CheckMode + -> RepairMode + -> m Bool +verifyStore check repair = doReq (VerifyStore check repair) diff --git a/src/System/Nix/Store/Remote/Client/Core.hs b/src/System/Nix/Store/Remote/Client/Core.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Client/Core.hs @@ -0,0 +1,229 @@ +module System.Nix.Store.Remote.Client.Core + ( Run + , greetServer + , doReq + ) where + +import Control.Monad (unless, when) +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.ByteString (ByteString) +import Data.DList (DList) +import Data.Some (Some(Some)) +import Data.Word (Word64) +import Network.Socket (Socket) +import System.Nix.Nar (NarSource) +import System.Nix.StorePath.Metadata (Metadata(..)) +import System.Nix.Store.Remote.Logger (processOutput) +import System.Nix.Store.Remote.MonadStore + ( MonadRemoteStore(..) + , RemoteStoreError(..) + ) +import System.Nix.Store.Remote.Socket (sockPutS, sockGetS) +import System.Nix.Store.Remote.Serializer + ( bool + , int + , mapErrorS + , protoVersion + , storeRequest + , text + , trustedFlag + , workerMagic + ) +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.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 + +type Run m a = m (Either RemoteStoreError a, DList Logger) + +-- | Perform @StoreRequest@ +doReq + :: forall m a + . ( MonadIO m + , MonadRemoteStore m + , StoreReply a + , Show a + ) + => StoreRequest a + -> m a +doReq = \case + x -> do + sockPutS + (mapErrorS + RemoteStoreError_SerializerRequest + storeRequest + ) + (Some x) + + case x of + AddToStore {} -> do + + ms <- takeNarSource + case ms of + Just (stream :: NarSource IO) -> do + soc <- getStoreSocket + liftIO + $ stream + $ Network.Socket.ByteString.sendAll soc + Nothing -> + throwError + RemoteStoreError_NoNarSourceProvided + processOutput + processReply + + AddToStoreNar _ meta _ _ -> do + let narBytes = maybe 0 id $ metadataNarBytes meta + maybeDataSource <- takeDataSource + soc <- getStoreSocket + case maybeDataSource of + Nothing -> + if narBytes == 0 then writeFramedSource (const (pure Nothing)) soc 0 + else throwError RemoteStoreError_NoDataSourceProvided + Just dataSource -> do + writeFramedSource dataSource soc narBytes + processOutput + pure NoReply + + NarFromPath _ -> do + maybeSink <- getDataSink + sink <- case maybeSink of + Nothing -> throwError RemoteStoreError_NoDataSinkProvided + Just sink -> pure sink + clearDataSink + maybeNarSize <- getDataSinkSize + narSize <- case maybeNarSize of + Nothing -> throwError RemoteStoreError_NoDataSinkSizeProvided + Just narSize -> pure narSize + clearDataSinkSize + soc <- getStoreSocket + processOutput + copyToSink sink narSize soc + pure NoReply + + _ -> do + processOutput + processReply + + where + processReply = sockGetS + (mapErrorS RemoteStoreError_SerializerReply + $ getReplyS @a + ) + +copyToSink + :: forall m + . ( MonadIO m + , MonadRemoteStore m + ) + => (ByteString -> IO()) -- ^ data sink + -> Word64 -- ^ byte length to read + -> Socket + -> m () +copyToSink sink remainingBytes soc = + when (remainingBytes > 0) $ do + let chunkSize = 16384 + bytesToRead = min chunkSize remainingBytes + bytes <- liftIO $ Network.Socket.ByteString.recv soc (fromIntegral bytesToRead) + liftIO $ sink bytes + let nextRemainingBytes = remainingBytes - (fromIntegral . Data.ByteString.length) bytes + copyToSink sink nextRemainingBytes soc + +writeFramedSource + :: forall m + . ( MonadIO m + , MonadRemoteStore m + ) + => (Word64 -> IO(Maybe ByteString)) + -> Socket + -> Word64 + -> m () +writeFramedSource dataSource soc remainingBytes = do + let chunkSize = 16384 + maybeBytes <- liftIO $ dataSource chunkSize + case maybeBytes of + Nothing -> do + unless (remainingBytes == 0) $ throwError RemoteStoreError_DataSourceExhausted + let eof :: Word64 = 0 + sockPutS int eof + Just bytes -> do + let bytesInChunk = fromIntegral $ Data.ByteString.length bytes + when (bytesInChunk > chunkSize || bytesInChunk > remainingBytes) $ throwError RemoteStoreError_DataSourceReadTooLarge + when (bytesInChunk == 0) $ throwError RemoteStoreError_DataSourceZeroLengthRead + sockPutS int bytesInChunk + liftIO + $ Network.Socket.ByteString.sendAll soc bytes + let nextRemainingBytes = remainingBytes - bytesInChunk + writeFramedSource dataSource soc nextRemainingBytes + +greetServer + :: MonadRemoteStore m + => m ClientHandshakeOutput +greetServer = do + sockPutS + (mapErrorS + RemoteStoreError_SerializerHandshake + workerMagic + ) + WorkerMagic_One + + magic <- + sockGetS + $ mapErrorS + RemoteStoreError_SerializerHandshake + workerMagic + + unless + (magic == WorkerMagic_Two) + $ throwError RemoteStoreError_WorkerMagic2Mismatch + + daemonVersion <- sockGetS protoVersion + + when (daemonVersion < ProtoVersion 1 10) + $ throwError RemoteStoreError_ClientVersionTooOld + + pv <- getProtoVersion + sockPutS protoVersion pv + + let leastCommonVersion = min daemonVersion pv + + when (leastCommonVersion >= ProtoVersion 1 14) + $ sockPutS int (0 :: Int) -- affinity, obsolete + + when (leastCommonVersion >= ProtoVersion 1 11) $ do + sockPutS + (mapErrorS RemoteStoreError_SerializerPut bool) + False -- reserveSpace, obsolete + + 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 + + remoteTrustsUs <- if leastCommonVersion >= ProtoVersion 1 35 + then do + sockGetS + $ mapErrorS RemoteStoreError_SerializerHandshake trustedFlag + else pure Nothing + + setProtoVersion leastCommonVersion + processOutput + + pure ClientHandshakeOutput + { clientHandshakeOutputNixVersion = daemonNixVersion + , clientHandshakeOutputTrust = remoteTrustsUs + , clientHandshakeOutputLeastCommonVersion = leastCommonVersion + , 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 @@ -1,86 +1,100 @@ -{-# language RankNTypes #-} - module System.Nix.Store.Remote.Logger - ( Logger(..) - , Field(..) - , processOutput - ) -where + ( processOutput + ) where +import Control.Monad.Except (throwError) +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.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 Prelude hiding ( Last ) -import Control.Monad.Except ( throwError ) -import Data.Binary.Get +import qualified Control.Monad +import qualified Data.Serialize.Get +import qualified Data.Serializer +import qualified Network.Socket.ByteString -import Network.Socket.ByteString ( recv ) +processOutput + :: MonadRemoteStore m + => m () +processOutput = do + protoVersion <- getProtoVersion + sockGet8 >>= go . (decoder protoVersion) + where + decoder + :: ProtoVersion + -> ByteString + -> Result (Either LoggerSError Logger) + decoder protoVersion = + Data.Serialize.Get.runGetPartial + (runSerialT protoVersion $ Data.Serializer.getS logger) -import System.Nix.Store.Remote.Binary -import System.Nix.Store.Remote.Types -import System.Nix.Store.Remote.Util + go + :: MonadRemoteStore m + => Result (Either LoggerSError Logger) + -> m () + go (Done ectrl leftover) = do + let loop = do + protoVersion <- getProtoVersion + sockGet8 >>= go . (decoder protoVersion) + Control.Monad.unless (leftover == mempty) $ + throwError + $ RemoteStoreError_LoggerLeftovers + (show ectrl) + leftover -controlParser :: Get Logger -controlParser = do - ctrl <- getInt - case (ctrl :: Int) of - 0x6f6c6d67 -> Next <$> getByteStringLen - 0x64617461 -> Read <$> getInt - 0x64617416 -> Write <$> getByteStringLen - 0x616c7473 -> pure Last - 0x63787470 -> flip Error <$> getByteStringLen - <*> getInt - 0x53545254 -> StartActivity <$> getInt - <*> getInt - <*> getInt - <*> getByteStringLen - <*> getFields - <*> getInt - 0x53544f50 -> StopActivity <$> getInt - 0x52534c54 -> Result <$> getInt - <*> getInt - <*> getFields - x -> fail $ "Invalid control message received:" <> show x + case ectrl of + Left e -> throwError $ RemoteStoreError_SerializerLogger e + Right ctrl -> do + case ctrl of + -- These two terminate the logger loop + Logger_Error e -> throwError $ RemoteStoreError_LoggerError e + Logger_Last -> appendLog Logger_Last -processOutput :: MonadStore [Logger] -processOutput = go decoder - where - decoder = runGetIncremental controlParser - go :: Decoder Logger -> MonadStore [Logger] - go (Done _leftover _consumed ctrl) = do - case ctrl of - e@(Error _ _) -> pure [e] - Last -> pure [Last] - Read _n -> do - (mdata, _) <- get - case mdata of - Nothing -> throwError "No data to read provided" - Just part -> do - -- XXX: we should check/assert part size against n of (Read n) - sockPut $ putByteStringLen part - clearData + -- Read data from source + Logger_Read size -> do + mSource <- getDataSource + case mSource of + Nothing -> + throwError RemoteStoreError_NoDataSourceProvided + Just source -> do + mChunk <- liftIO $ source size + case mChunk of + Nothing -> throwError RemoteStoreError_DataSourceExhausted + Just chunk -> do + sock <- getStoreSocket + liftIO $ Network.Socket.ByteString.sendAll sock chunk - go decoder + loop - -- we should probably handle Read here as well - x -> do - next <- go decoder - pure $ x : next - go (Partial k) = do - soc <- asks storeSocket - chunk <- liftIO (Just <$> recv soc 8) - go (k chunk) + -- Write data to sink + Logger_Write out -> do + mSink <- getDataSink + case mSink of + Nothing -> + throwError RemoteStoreError_NoDataSinkProvided + Just sink -> do + liftIO $ sink out - go (Fail _leftover _consumed msg) = error $ fromString msg + loop -getFields :: Get [Field] -getFields = do - cnt <- getInt - replicateM cnt getField + -- Following we just append and loop + -- but listed here explicitely for posterity + x@(Logger_Next _) -> appendLog x >> loop + x@(Logger_StartActivity {}) -> appendLog x >> loop + x@(Logger_StopActivity {}) -> appendLog x >> loop + x@(Logger_Result {}) -> appendLog x >> loop -getField :: Get Field -getField = do - typ <- getInt - case (typ :: Int) of - 0 -> LogInt <$> getInt - 1 -> LogStr <$> getByteStringLen - x -> fail $ "Unknown log type: " <> show x + go (Partial k) = do + chunk <- sockGet8 + go (k chunk) + + go (Fail msg leftover) = + throwError + $ RemoteStoreError_LoggerParserFail + msg + leftover diff --git a/src/System/Nix/Store/Remote/MonadStore.hs b/src/System/Nix/Store/Remote/MonadStore.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/MonadStore.hs @@ -0,0 +1,390 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module System.Nix.Store.Remote.MonadStore + ( RemoteStoreState(..) + , RemoteStoreError(..) + , WorkerError(..) + , WorkerException(..) + , RemoteStoreT + , runRemoteStoreT + , MonadRemoteStore(..) + ) where + +import Control.Exception (SomeException) +import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) +import Control.Monad.Except (MonadError) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Reader (MonadReader, ask) +import Control.Monad.State.Strict (get, gets, modify) +import Control.Monad.Trans (MonadTrans, lift) +import Control.Monad.Trans.State.Strict (StateT, runStateT) +import Control.Monad.Trans.Except (ExceptT, runExceptT) +import Control.Monad.Trans.Reader (ReaderT, runReaderT) +import Data.ByteString (ByteString) +import Data.Default.Class (Default(def)) +import Data.DList (DList) +import Data.Word (Word64) +import Network.Socket (Socket) +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.StoreConfig (ProtoStoreConfig(..)) + +import qualified Data.DList + +data RemoteStoreState = RemoteStoreState { + remoteStoreStateConfig :: ProtoStoreConfig + , remoteStoreStateLogs :: DList Logger + , remoteStoreStateMDataSource :: Maybe (Word64 -> IO (Maybe ByteString)) + -- ^ Source for @Logger_Read@, this will be called repeatedly + -- as the daemon requests chunks of size @Word64@. + -- If the function returns Nothing and daemon tries to read more + -- data an error is thrown. + -- Used by @AddToStoreNar@ and @ImportPaths@ operations. + , remoteStoreStateMDataSink :: Maybe (ByteString -> IO ()) + -- ^ Sink for @Logger_Write@, called repeatedly by the daemon + -- to dump us some data. Used by @ExportPath@ operation. + , remoteStoreStateMDataSinkSize :: Maybe Word64 + -- ^ Byte length to be written to the sink, for NarForPath + , remoteStoreStateMNarSource :: Maybe (NarSource IO) + } + +instance HasStoreDir RemoteStoreState where + hasStoreDir = hasStoreDir . remoteStoreStateConfig + +instance HasProtoVersion RemoteStoreState where + hasProtoVersion = hasProtoVersion . remoteStoreStateConfig + +data RemoteStoreError + = RemoteStoreError_Fixme String + | RemoteStoreError_BuildFailed + | RemoteStoreError_ClientVersionTooOld + | RemoteStoreError_DerivationParse String + | RemoteStoreError_Disconnected + | RemoteStoreError_GetAddrInfoFailed + | RemoteStoreError_GenericIncrementalLeftovers String ByteString -- when there are bytes left over after genericIncremental parser is done, (Done x leftover), first param is show x + | RemoteStoreError_GenericIncrementalFail String ByteString -- when genericIncremental parser returns ((Fail msg leftover) :: Result) + | RemoteStoreError_SerializerGet SError + | RemoteStoreError_SerializerHandshake HandshakeSError + | RemoteStoreError_SerializerLogger LoggerSError + | RemoteStoreError_SerializerPut SError + | RemoteStoreError_SerializerRequest RequestSError + | RemoteStoreError_SerializerReply ReplySError + | RemoteStoreError_IOException SomeException + | RemoteStoreError_LoggerError (Either BasicError 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 + | RemoteStoreError_DataSourceExhausted -- remoteStoreStateMDataSource returned Nothing but more data was requested + | RemoteStoreError_DataSourceZeroLengthRead -- remoteStoreStateMDataSource returned a zero length ByteString + | RemoteStoreError_DataSourceReadTooLarge -- remoteStoreStateMDataSource returned a ByteString larger than the chunk size requested or the remaining bytes + | RemoteStoreError_NoDataSinkProvided -- remoteStoreStateMDataSink is required but it is Nothing + | RemoteStoreError_NoDataSinkSizeProvided -- remoteStoreStateMDataSinkSize is required but it is Nothing + | RemoteStoreError_NoNarSourceProvided + | RemoteStoreError_OperationFailed + | RemoteStoreError_ProtocolMismatch + | RemoteStoreError_RapairNotSupportedByRemoteStore -- "repairing is not supported when building through the Nix daemon" + | RemoteStoreError_WorkerMagic2Mismatch + | RemoteStoreError_WorkerError WorkerError + -- bad / redundant + | RemoteStoreError_WorkerException WorkerException + deriving Show + +-- | fatal error in worker interaction which should disconnect client. +data WorkerException + = WorkerException_ClientVersionTooOld + | WorkerException_ProtocolMismatch + | WorkerException_Error WorkerError + -- ^ allowed error outside allowed worker state +-- | WorkerException_DecodingError DecodingError +-- | WorkerException_BuildFailed StorePath + deriving (Eq, Ord, Show) + +-- | Non-fatal (to server) errors in worker interaction +data WorkerError + = WorkerError_SendClosed + | WorkerError_InvalidOperation Word64 + | WorkerError_NotYetImplemented + | WorkerError_UnsupportedOperation + deriving (Eq, Ord, Show) + +newtype RemoteStoreT m a = RemoteStoreT + { _unRemoteStoreT + :: ExceptT RemoteStoreError + (StateT RemoteStoreState + (ReaderT Socket m)) a + } + deriving + ( Functor + , Applicative + , Monad + , MonadReader Socket + --, MonadState StoreState -- Avoid making the internal state explicit + , MonadError RemoteStoreError + , MonadCatch + , MonadMask + , MonadThrow + , MonadIO + ) + +instance MonadTrans RemoteStoreT where + lift = RemoteStoreT . lift . lift . lift + +-- | Runner for @RemoteStoreT@ +runRemoteStoreT + :: Monad m + => Socket + -> RemoteStoreT m a + -> m (Either RemoteStoreError a, DList Logger) +runRemoteStoreT sock = + fmap (\(res, RemoteStoreState{..}) -> (res, remoteStoreStateLogs)) + . (`runReaderT` sock) + . (`runStateT` emptyState) + . runExceptT + . _unRemoteStoreT + where + emptyState = RemoteStoreState + { remoteStoreStateConfig = def + , remoteStoreStateLogs = mempty + , remoteStoreStateMDataSource = Nothing + , remoteStoreStateMDataSink = Nothing + , remoteStoreStateMDataSinkSize = Nothing + , remoteStoreStateMNarSource = Nothing + } + +class ( MonadIO m + , MonadError RemoteStoreError m + ) + => MonadRemoteStore m where + + appendLog :: Logger -> m () + default appendLog + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => Logger + -> m () + appendLog = lift . appendLog + + getConfig :: m ProtoStoreConfig + default getConfig + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => m ProtoStoreConfig + getConfig = lift getConfig + + getStoreDir :: m StoreDir + default getStoreDir + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => m StoreDir + getStoreDir = lift getStoreDir + + setStoreDir :: StoreDir -> m () + default setStoreDir + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => StoreDir + -> m () + setStoreDir = lift . setStoreDir + + -- | Get @ProtoVersion@ from state + getProtoVersion :: m ProtoVersion + default getProtoVersion + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => m ProtoVersion + getProtoVersion = lift getProtoVersion + + setProtoVersion :: ProtoVersion -> m () + default setProtoVersion + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => ProtoVersion + -> m () + setProtoVersion = lift . setProtoVersion + + getStoreSocket :: m Socket + default getStoreSocket + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => m Socket + getStoreSocket = lift getStoreSocket + + setNarSource :: NarSource IO -> m () + default setNarSource + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => NarSource IO + -> m () + setNarSource x = lift (setNarSource x) + + takeNarSource :: m (Maybe (NarSource IO)) + default takeNarSource + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => m (Maybe (NarSource IO)) + takeNarSource = lift takeNarSource + + setDataSource :: (Word64 -> IO (Maybe ByteString)) -> m () + default setDataSource + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => (Word64 -> IO (Maybe ByteString)) + -> m () + setDataSource x = lift (setDataSource x) + + takeDataSource :: m (Maybe (Word64 -> IO (Maybe ByteString))) + default takeDataSource + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => m (Maybe (Word64 -> IO (Maybe ByteString))) + takeDataSource = lift takeDataSource + + getDataSource :: m (Maybe (Word64 -> IO (Maybe ByteString))) + default getDataSource + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => m (Maybe (Word64 -> IO (Maybe ByteString))) + getDataSource = lift getDataSource + + clearDataSource :: m () + default clearDataSource + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => m () + clearDataSource = lift clearDataSource + + setDataSink :: (ByteString -> IO ()) -> m () + default setDataSink + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => (ByteString -> IO ()) + -> m () + setDataSink x = lift (setDataSink x) + + getDataSink :: m (Maybe (ByteString -> IO ())) + default getDataSink + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => m (Maybe (ByteString -> IO ())) + getDataSink = lift getDataSink + + clearDataSink :: m () + default clearDataSink + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => m () + clearDataSink = lift clearDataSink + + setDataSinkSize :: Word64 -> m () + default setDataSinkSize + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => Word64 + -> m () + setDataSinkSize x = lift (setDataSinkSize x) + + getDataSinkSize :: m (Maybe Word64) + default getDataSinkSize + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => m (Maybe Word64) + getDataSinkSize = lift getDataSinkSize + + clearDataSinkSize :: m () + default clearDataSinkSize + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => m () + clearDataSinkSize = lift clearDataSinkSize + +instance MonadRemoteStore m => MonadRemoteStore (StateT s m) +instance MonadRemoteStore m => MonadRemoteStore (ReaderT r m) +instance MonadRemoteStore m => MonadRemoteStore (ExceptT RemoteStoreError m) + +instance MonadIO m => MonadRemoteStore (RemoteStoreT m) where + + getConfig = RemoteStoreT $ gets remoteStoreStateConfig + getProtoVersion = RemoteStoreT $ gets hasProtoVersion + setProtoVersion pv = + RemoteStoreT $ modify $ \s -> + s { remoteStoreStateConfig = + (remoteStoreStateConfig s) { protoStoreConfigProtoVersion = pv } + } + getStoreDir = RemoteStoreT $ gets hasStoreDir + setStoreDir sd = + RemoteStoreT $ modify $ \s -> + s { remoteStoreStateConfig = + (remoteStoreStateConfig s) { protoStoreConfigDir = sd } + } + + getStoreSocket = RemoteStoreT ask + + appendLog x = + RemoteStoreT + $ modify + $ \s -> s { remoteStoreStateLogs = remoteStoreStateLogs s `Data.DList.snoc` x } + + setDataSource x = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMDataSource = pure x } + getDataSource = RemoteStoreT (gets remoteStoreStateMDataSource) + clearDataSource = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMDataSource = Nothing } + + takeDataSource = RemoteStoreT $ do + x <- remoteStoreStateMDataSource <$> get + modify $ \s -> s { remoteStoreStateMDataSource = Nothing } + pure x + + setDataSink x = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMDataSink = pure x } + getDataSink = RemoteStoreT (gets remoteStoreStateMDataSink) + clearDataSink = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMDataSink = Nothing } + + setDataSinkSize x = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMDataSinkSize = pure x } + getDataSinkSize = RemoteStoreT (gets remoteStoreStateMDataSinkSize) + clearDataSinkSize = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMDataSinkSize = Nothing } + + setNarSource x = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMNarSource = pure x } + takeNarSource = RemoteStoreT $ do + x <- remoteStoreStateMNarSource <$> get + modify $ \s -> s { remoteStoreStateMNarSource = Nothing } + pure x diff --git a/src/System/Nix/Store/Remote/Parsers.hs b/src/System/Nix/Store/Remote/Parsers.hs deleted file mode 100644 --- a/src/System/Nix/Store/Remote/Parsers.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# language AllowAmbiguousTypes #-} -{-# language ScopedTypeVariables #-} -{-# language RankNTypes #-} -{-# language DataKinds #-} - -module System.Nix.Store.Remote.Parsers - ( parseContentAddressableAddress - ) -where - -import Data.Attoparsec.ByteString.Char8 -import System.Nix.Hash -import System.Nix.StorePath ( ContentAddressableAddress(..) - , NarHashMode(..) - ) -import Crypto.Hash ( SHA256 ) - --- | Parse `ContentAddressableAddress` from `ByteString` -parseContentAddressableAddress - :: ByteString -> Either String ContentAddressableAddress -parseContentAddressableAddress = - Data.Attoparsec.ByteString.Char8.parseOnly contentAddressableAddressParser - --- | Parser for content addressable field -contentAddressableAddressParser :: Parser ContentAddressableAddress -contentAddressableAddressParser = caText <|> caFixed - --- | Parser for @text:sha256:@ -caText :: Parser ContentAddressableAddress -caText = do - _ <- "text:sha256:" - digest <- decodeDigestWith @SHA256 NixBase32 <$> parseHash - either fail pure $ Text <$> digest - --- | Parser for @fixed:::@ -caFixed :: Parser ContentAddressableAddress -caFixed = do - _ <- "fixed:" - narHashMode <- (Recursive <$ "r:") <|> (RegularFile <$ "") - digest <- parseTypedDigest - either fail pure $ Fixed narHashMode <$> digest - -parseTypedDigest :: Parser (Either String SomeNamedDigest) -parseTypedDigest = mkNamedDigest <$> parseHashType <*> parseHash - -parseHashType :: Parser Text -parseHashType = - decodeUtf8 <$> ("sha256" <|> "sha512" <|> "sha1" <|> "md5") <* (":" <|> "-") - -parseHash :: Parser Text -parseHash = decodeUtf8 <$> takeWhile1 (/= ':') diff --git a/src/System/Nix/Store/Remote/Protocol.hs b/src/System/Nix/Store/Remote/Protocol.hs deleted file mode 100644 --- a/src/System/Nix/Store/Remote/Protocol.hs +++ /dev/null @@ -1,215 +0,0 @@ -{-# language DataKinds #-} -{-# language ScopedTypeVariables #-} -{-# LANGUAGE LambdaCase #-} -module System.Nix.Store.Remote.Protocol - ( WorkerOp(..) - , simpleOp - , simpleOpArgs - , runOp - , runOpArgs - , runOpArgsIO - , runStore - , runStoreOpts - , runStoreOptsTCP - , runStoreOpts' - ) -where - -import qualified Relude.Unsafe as Unsafe - -import Control.Exception ( bracket ) -import Control.Monad.Except - -import Data.Binary.Get -import Data.Binary.Put -import qualified Data.ByteString -import qualified Data.ByteString.Char8 - -import Network.Socket ( SockAddr(SockAddrUnix) ) -import qualified Network.Socket as S -import Network.Socket.ByteString ( recv - , sendAll - ) - -import System.Nix.Store.Remote.Binary -import System.Nix.Store.Remote.Logger -import System.Nix.Store.Remote.Types -import System.Nix.Store.Remote.Util - - -protoVersion :: Int -protoVersion = 0x115 --- major protoVersion & 0xFF00 --- minor .. & 0x00FF - -workerMagic1 :: Int -workerMagic1 = 0x6e697863 -workerMagic2 :: Int -workerMagic2 = 0x6478696f - -defaultSockPath :: String -defaultSockPath = "/nix/var/nix/daemon-socket/socket" - -data WorkerOp = - IsValidPath - | HasSubstitutes - | QueryReferrers - | AddToStore - | AddTextToStore - | BuildPaths - | EnsurePath - | AddTempRoot - | AddIndirectRoot - | SyncWithGC - | FindRoots - | SetOptions - | CollectGarbage - | QuerySubstitutablePathInfo - | QueryDerivationOutputs - | QueryAllValidPaths - | QueryFailedPaths - | ClearFailedPaths - | QueryPathInfo - | QueryDerivationOutputNames - | QueryPathFromHashPart - | QuerySubstitutablePathInfos - | QueryValidPaths - | QuerySubstitutablePaths - | QueryValidDerivers - | OptimiseStore - | VerifyStore - | BuildDerivation - | AddSignatures - | NarFromPath - | AddToStoreNar - | QueryMissing - deriving (Eq, Ord, Show) - -opNum :: WorkerOp -> Int -opNum IsValidPath = 1 -opNum HasSubstitutes = 3 -opNum QueryReferrers = 6 -opNum AddToStore = 7 -opNum AddTextToStore = 8 -opNum BuildPaths = 9 -opNum EnsurePath = 10 -opNum AddTempRoot = 11 -opNum AddIndirectRoot = 12 -opNum SyncWithGC = 13 -opNum FindRoots = 14 -opNum SetOptions = 19 -opNum CollectGarbage = 20 -opNum QuerySubstitutablePathInfo = 21 -opNum QueryDerivationOutputs = 22 -opNum QueryAllValidPaths = 23 -opNum QueryFailedPaths = 24 -opNum ClearFailedPaths = 25 -opNum QueryPathInfo = 26 -opNum QueryDerivationOutputNames = 28 -opNum QueryPathFromHashPart = 29 -opNum QuerySubstitutablePathInfos = 30 -opNum QueryValidPaths = 31 -opNum QuerySubstitutablePaths = 32 -opNum QueryValidDerivers = 33 -opNum OptimiseStore = 34 -opNum VerifyStore = 35 -opNum BuildDerivation = 36 -opNum AddSignatures = 37 -opNum NarFromPath = 38 -opNum AddToStoreNar = 39 -opNum QueryMissing = 40 - - -simpleOp :: WorkerOp -> MonadStore Bool -simpleOp op = simpleOpArgs op pass - -simpleOpArgs :: WorkerOp -> Put -> MonadStore Bool -simpleOpArgs op args = do - runOpArgs op args - err <- gotError - bool - sockGetBool - (do - Error _num msg <- Unsafe.head <$> getError - throwError $ Data.ByteString.Char8.unpack msg - ) - err - -runOp :: WorkerOp -> MonadStore () -runOp op = runOpArgs op pass - -runOpArgs :: WorkerOp -> Put -> MonadStore () -runOpArgs op args = - runOpArgsIO - op - (\encode -> encode $ toStrict $ runPut args) - -runOpArgsIO - :: WorkerOp - -> ((Data.ByteString.ByteString -> MonadStore ()) -> MonadStore ()) - -> MonadStore () -runOpArgsIO op encoder = do - - sockPut $ putInt $ opNum op - - soc <- asks storeSocket - encoder (liftIO . sendAll soc) - - out <- processOutput - modify (\(a, b) -> (a, b <> out)) - err <- gotError - when err $ do - Error _num msg <- Unsafe.head <$> getError - throwError $ Data.ByteString.Char8.unpack msg - -runStore :: MonadStore a -> IO (Either String a, [Logger]) -runStore = runStoreOpts defaultSockPath "/nix/store" - -runStoreOpts - :: FilePath -> FilePath -> MonadStore a -> IO (Either String a, [Logger]) -runStoreOpts path = runStoreOpts' S.AF_UNIX (SockAddrUnix path) - -runStoreOptsTCP - :: String -> Int -> FilePath -> MonadStore a -> IO (Either String a, [Logger]) -runStoreOptsTCP host port storeRootDir code = do - S.getAddrInfo (Just S.defaultHints) (Just host) (Just $ show port) >>= \case - (sockAddr:_) -> runStoreOpts' (S.addrFamily sockAddr) (S.addrAddress sockAddr) storeRootDir code - _ -> pure (Left "Couldn't resolve host and port with getAddrInfo.", []) - -runStoreOpts' - :: S.Family -> S.SockAddr -> FilePath -> MonadStore a -> IO (Either String a, [Logger]) -runStoreOpts' sockFamily sockAddr storeRootDir code = - bracket open (S.close . storeSocket) run - - where - open = do - soc <- S.socket sockFamily S.Stream 0 - S.connect soc sockAddr - pure StoreConfig - { storeSocket = soc - , storeDir = storeRootDir - } - - greet = do - sockPut $ putInt workerMagic1 - soc <- asks storeSocket - vermagic <- liftIO $ recv soc 16 - let - (magic2, _daemonProtoVersion) = - flip runGet (fromStrict vermagic) - $ (,) - <$> (getInt :: Get Int) - <*> (getInt :: Get Int) - unless (magic2 == workerMagic2) $ error "Worker magic 2 mismatch" - - sockPut $ putInt protoVersion -- clientVersion - sockPut $ putInt (0 :: Int) -- affinity - sockPut $ putInt (0 :: Int) -- obsolete reserveSpace - - processOutput - - run sock = - fmap (\(res, (_data, logs)) -> (res, logs)) - $ (`runReaderT` sock) - $ (`runStateT` (Nothing, [])) - $ runExceptT (greet >> code) diff --git a/src/System/Nix/Store/Remote/Serializer.hs b/src/System/Nix/Store/Remote/Serializer.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Serializer.hs @@ -0,0 +1,1567 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-| +Description : NixSerializer +Copyright : (c) John Ericson, 2023 + Sorki, 2023 +|-} + +module System.Nix.Store.Remote.Serializer + ( + -- * 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 + } diff --git a/src/System/Nix/Store/Remote/Server.hs b/src/System/Nix/Store/Remote/Server.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Server.hs @@ -0,0 +1,365 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +module System.Nix.Store.Remote.Server + ( runProxyDaemon + , WorkerHelper + ) + where + +import Control.Concurrent.Classy.Async +import Control.Monad (join, void, when) +import Control.Monad.Conc.Class (MonadConc) +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.Trans (lift) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Default.Class (Default(def)) +import Data.Foldable (traverse_) +import Data.IORef (IORef, atomicModifyIORef, newIORef) +import Data.Text (Text) +import Data.Void (Void, absurd) +import Data.Word (Word32) +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.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.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 + +type WorkerHelper m + = forall a + . ( Show a + , StoreReply a + ) + => RemoteStoreT m a + -> Run m a + +chatty :: Bool +chatty = False + +dbg :: MonadIO m => Text -> m () +dbg = when chatty . liftIO . Data.Text.IO.putStrLn + +-- | Run an emulated nix daemon on given socket address. +-- The deamon will close when the continuation returns. +runProxyDaemon + :: forall m a + . ( MonadIO m + , MonadConc m + ) + => WorkerHelper m + -> RemoteStoreT m () + -> Socket + -> m a + -> m a +runProxyDaemon workerHelper postGreet lsock k = do + liftIO $ listen lsock maxListenQueue + + dbg "listening" + + let listener :: m Void + listener = do + (sock, _) <- liftIO $ accept lsock + dbg "accepting" + + -- TODO: this, but without the space leak + fmap fst + $ concurrently listener + $ processConnection workerHelper postGreet sock + + either absurd id <$> race listener k + +-- | "main loop" of the daemon for a single connection. +-- +-- this function should take care to not throw errors from client connections. +processConnection + :: forall m + . MonadIO m + => WorkerHelper m + -> RemoteStoreT m () + -> Socket + -> m () +processConnection workerHelper postGreet sock = do + ~() <- void $ runRemoteStoreT sock $ do + + ServerHandshakeOutput{..} + <- greet + ServerHandshakeInput + { serverHandshakeInputNixVersion = "nixVersion (hnix-store-remote)" + , serverHandshakeInputOurVersion = def + , serverHandshakeInputTrust = Nothing + } + + setProtoVersion serverHandshakeOutputLeastCommonVersion + + tunnelLogger <- liftIO $ newTunnelLogger + -- Send startup error messages to the client. + startWork tunnelLogger + + -- TODO: do we need auth at all? probably? + -- If we can't accept clientVersion, then throw an error *here* (not above). + --authHook(*store); + stopWork tunnelLogger + + -- so we can set store dir + postGreet + + let perform + :: ( Show a + , StoreReply a + ) + => StoreRequest a + -> RemoteStoreT m () + perform req = do + + 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 + + pure $ setNarSource proxyNarSource + _ -> pure $ pure () + + res <- + bracketLogger + tunnelLogger + $ lift + $ workerHelper + $ special >> doReq req + + case fst res of + Left e -> throwError e + Right reply -> + sockPutS + (mapErrorS + RemoteStoreError_SerializerReply + $ getReplyS + ) + reply + + -- Process client requests. + let loop = do + someReq <- + sockGetS + $ mapErrorS + RemoteStoreError_SerializerRequest + storeRequest + + -- have to be explicit here + -- because otherwise GHC can't conjure Show a, StoreReply a + -- out of thin air + () <- Data.Some.withSome someReq $ \case + r@AddToStore {} -> perform r + r@AddToStoreNar {} -> perform r + r@AddTextToStore {} -> perform r + r@AddSignatures {} -> perform r + r@AddTempRoot {} -> perform r + r@AddIndirectRoot {} -> perform r + r@BuildDerivation {} -> perform r + r@BuildPaths {} -> perform r + r@CollectGarbage {} -> perform r + r@EnsurePath {} -> perform r + r@FindRoots {} -> perform r + r@IsValidPath {} -> perform r + r@NarFromPath {} -> perform r + r@QueryValidPaths {} -> perform r + r@QueryAllValidPaths {} -> perform r + r@QuerySubstitutablePaths {} -> perform r + r@QueryPathInfo {} -> perform r + r@QueryReferrers {} -> perform r + r@QueryValidDerivers {} -> perform r + r@QueryDerivationOutputs {} -> perform r + r@QueryDerivationOutputNames {} -> perform r + r@QueryPathFromHashPart {} -> perform r + r@QueryMissing {} -> perform r + r@OptimiseStore {} -> perform r + r@SyncWithGC {} -> perform r + r@VerifyStore {} -> perform r + loop + loop + + dbg "daemon connection done" + liftIO $ close sock + + where + -- Exchange the greeting. + greet + :: MonadIO m + => ServerHandshakeInput + -> RemoteStoreT m ServerHandshakeOutput + greet ServerHandshakeInput{..} = do + magic <- + sockGetS + $ mapErrorS + RemoteStoreError_SerializerHandshake + workerMagic + + when (magic /= WorkerMagic_One) + $ throwError + $ RemoteStoreError_WorkerException + WorkerException_ProtocolMismatch + + sockPutS + (mapErrorS + RemoteStoreError_SerializerHandshake + workerMagic + ) + WorkerMagic_Two + + sockPutS protoVersion serverHandshakeInputOurVersion + + clientVersion <- sockGetS protoVersion + + let leastCommonVersion = min clientVersion serverHandshakeInputOurVersion + + when (clientVersion < ProtoVersion 1 10) + $ 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 () + + when (clientVersion >= ProtoVersion 1 11) $ do + _ :: Word32 <- sockGetS int -- obsolete reserveSpace + pure () + + when (clientVersion >= ProtoVersion 1 33) $ do + sockPutS + (mapErrorS + RemoteStoreError_SerializerPut + text + ) + serverHandshakeInputNixVersion + + when (clientVersion >= ProtoVersion 1 35) $ do + sockPutS + (mapErrorS + RemoteStoreError_SerializerHandshake + trustedFlag + ) + serverHandshakeInputTrust + + pure ServerHandshakeOutput + { serverHandshakeOutputLeastCommonVersion = leastCommonVersion + , serverHandshakeOutputClientVersion = clientVersion + } + +{-# WARNING _unimplemented "not yet implemented" #-} +_unimplemented :: RemoteStoreError +_unimplemented = RemoteStoreError_WorkerException $ WorkerException_Error $ WorkerError_NotYetImplemented + +bracketLogger + :: MonadRemoteStore m + => TunnelLogger + -> m a + -> m a +bracketLogger tunnelLogger m = do + startWork tunnelLogger + a <- m + stopWork tunnelLogger + pure a + +--- + +data TunnelLogger = TunnelLogger + { _tunnelLogger_state :: IORef TunnelLoggerState + } + +data TunnelLoggerState = TunnelLoggerState + { _tunnelLoggerState_canSendStderr :: Bool + , _tunnelLoggerState_pendingMsgs :: [Logger] + } + +newTunnelLogger :: IO TunnelLogger +newTunnelLogger = TunnelLogger <$> newIORef (TunnelLoggerState False []) + +enqueueMsg + :: ( MonadRemoteStore m + , MonadError LoggerSError m + ) + => TunnelLogger + -> Logger + -> m () +enqueueMsg x l = updateLogger x $ \st@(TunnelLoggerState c p) -> case c of + True -> (st, sockPutS logger l) + False -> (TunnelLoggerState c (l:p), pure ()) + +_log + :: ( MonadRemoteStore m + , MonadError LoggerSError m + ) + => TunnelLogger + -> Text + -> m () +_log l s = enqueueMsg l (Logger_Next s) + +startWork + :: MonadRemoteStore m + => TunnelLogger + -> m () +startWork x = updateLogger x $ \(TunnelLoggerState _ p) -> (,) + (TunnelLoggerState True []) $ + (traverse_ (sockPutS logger') $ reverse p) + where logger' = mapErrorS RemoteStoreError_SerializerLogger logger + +stopWork + :: MonadRemoteStore m + => TunnelLogger + -> m () +stopWork x = updateLogger x $ \_ -> (,) + (TunnelLoggerState False []) + (sockPutS (mapErrorS RemoteStoreError_SerializerLogger logger) Logger_Last) + +-- | Stop sending logging and report an error. +-- +-- Returns true if the the session was in a state that allowed the error to be +-- sent. +-- +-- Unlike 'stopWork', this function may be called at any time to (try) to end a +-- session with an error. +_stopWorkOnError + :: MonadRemoteStore m + => TunnelLogger + -> ErrorInfo + -> m Bool +_stopWorkOnError x ex = updateLogger x $ \st -> + 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)))) + pure True + where logger' = mapErrorS RemoteStoreError_SerializerLogger logger + +updateLogger + :: MonadRemoteStore m + => TunnelLogger + -> (TunnelLoggerState -> (TunnelLoggerState, m a)) + -> m a +updateLogger x = join . liftIO . atomicModifyIORef (_tunnelLogger_state x) diff --git a/src/System/Nix/Store/Remote/Socket.hs b/src/System/Nix/Store/Remote/Socket.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Socket.hs @@ -0,0 +1,101 @@ +module System.Nix.Store.Remote.Socket where + +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.ByteString (ByteString) +import Data.Serialize.Get (Get, Result(..)) +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 qualified Control.Exception +import qualified Data.ByteString +import qualified Data.Serializer +import qualified Data.Serialize.Get + +genericIncremental + :: ( MonadIO m + , MonadError RemoteStoreError m + , Show a + ) + => m ByteString + -> Get a + -> m a +genericIncremental getsome parser = do + getsome >>= go . decoder + where + decoder = Data.Serialize.Get.runGetPartial parser + go (Done x leftover) | leftover /= mempty = + throwError + $ RemoteStoreError_GenericIncrementalLeftovers + (show x) + leftover + + go (Done x _leftover) = pure x + + go (Partial k) = do + chunk <- getsome + go (k chunk) + + go (Fail msg leftover) = + throwError + $ RemoteStoreError_GenericIncrementalFail + msg + leftover + +sockGet8 + :: MonadRemoteStore m + => m ByteString +sockGet8 = do + soc <- getStoreSocket + eresult <- liftIO $ Control.Exception.try $ recv soc 8 + case eresult of + Left e -> + throwError $ RemoteStoreError_IOException e + + Right result | Data.ByteString.length result == 0 -> + throwError RemoteStoreError_Disconnected + + Right result | otherwise -> + pure result + +sockPut + :: MonadRemoteStore m + => Put + -> m () +sockPut p = do + soc <- getStoreSocket + liftIO $ sendAll soc $ runPut p + +sockPutS + :: ( MonadRemoteStore m + , MonadError e m + ) + => NixSerializer ProtoStoreConfig 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 + +sockGetS + :: ( MonadRemoteStore m + , MonadError e m + , Show a + , Show e + ) + => NixSerializer ProtoStoreConfig e a + -> m a +sockGetS s = do + cfg <- getConfig + res <- genericIncremental sockGet8 + $ runSerialT cfg $ Data.Serializer.getS s + + case res of + Right x -> pure x + Left e -> throwError e diff --git a/src/System/Nix/Store/Remote/Types.hs b/src/System/Nix/Store/Remote/Types.hs --- a/src/System/Nix/Store/Remote/Types.hs +++ b/src/System/Nix/Store/Remote/Types.hs @@ -1,77 +1,33 @@ -{-# language DataKinds #-} -{-# language KindSignatures #-} -{-# language ScopedTypeVariables #-} module System.Nix.Store.Remote.Types - ( MonadStore - , StoreConfig(..) - , Logger(..) - , Field(..) - , getStoreDir - , getLog - , flushLog - , gotError - , getError - , setData - , clearData - ) -where - - -import qualified Data.ByteString.Lazy as BSL -import Network.Socket ( Socket ) - -data StoreConfig = StoreConfig - { storeDir :: FilePath - , storeSocket :: Socket - } - -type MonadStore a - = ExceptT - String - (StateT (Maybe BSL.ByteString, [Logger]) (ReaderT StoreConfig IO)) - a - -type ActivityID = Int -type ActivityParentID = Int -type ActivityType = Int -type Verbosity = Int -type ResultType = Int - -data Field = LogStr ByteString | LogInt Int - deriving (Eq, Ord, Show) - -data Logger = - Next ByteString - | Read Int -- data needed from source - | Write ByteString -- data for sink - | Last - | Error Int ByteString - | StartActivity ActivityID Verbosity ActivityType ByteString [Field] ActivityParentID - | StopActivity ActivityID - | Result ActivityID ResultType [Field] - deriving (Eq, Ord, Show) - -isError :: Logger -> Bool -isError (Error _ _) = True -isError _ = False - -gotError :: MonadStore Bool -gotError = gets (any isError . snd) - -getError :: MonadStore [Logger] -getError = gets (filter isError . snd) - -getLog :: MonadStore [Logger] -getLog = gets snd - -flushLog :: MonadStore () -flushLog = modify (\(a, _b) -> (a, [])) - -setData :: BSL.ByteString -> MonadStore () -setData x = modify (\(_, b) -> (Just x, b)) - -clearData :: MonadStore () -clearData = modify (\(_, b) -> (Nothing, b)) + ( module System.Nix.Store.Remote.Types.Activity + , module System.Nix.Store.Remote.Types.GC + , module System.Nix.Store.Remote.Types.CheckMode + , module System.Nix.Store.Remote.Types.Logger + , module System.Nix.Store.Remote.Types.ProtoVersion + , module System.Nix.Store.Remote.Types.Query + , module System.Nix.Store.Remote.Types.StoreConfig + , module System.Nix.Store.Remote.Types.StoreRequest + , module System.Nix.Store.Remote.Types.StoreText + , module System.Nix.Store.Remote.Types.SubstituteMode + , module System.Nix.Store.Remote.Types.SuccessCodeReply + , module System.Nix.Store.Remote.Types.TrustedFlag + , module System.Nix.Store.Remote.Types.Verbosity + , module System.Nix.Store.Remote.Types.WorkerMagic + , module System.Nix.Store.Remote.Types.WorkerOp + ) where -getStoreDir :: MonadStore FilePath -getStoreDir = asks storeDir +import System.Nix.Store.Remote.Types.Activity +import System.Nix.Store.Remote.Types.GC +import System.Nix.Store.Remote.Types.CheckMode +import System.Nix.Store.Remote.Types.Logger +import System.Nix.Store.Remote.Types.ProtoVersion +import System.Nix.Store.Remote.Types.Query +import System.Nix.Store.Remote.Types.StoreConfig +import System.Nix.Store.Remote.Types.StoreRequest +import System.Nix.Store.Remote.Types.StoreText +import System.Nix.Store.Remote.Types.SubstituteMode +import System.Nix.Store.Remote.Types.SuccessCodeReply +import System.Nix.Store.Remote.Types.TrustedFlag +import System.Nix.Store.Remote.Types.Verbosity +import System.Nix.Store.Remote.Types.WorkerMagic +import System.Nix.Store.Remote.Types.WorkerOp diff --git a/src/System/Nix/Store/Remote/Types/Activity.hs b/src/System/Nix/Store/Remote/Types/Activity.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Types/Activity.hs @@ -0,0 +1,55 @@ +module System.Nix.Store.Remote.Types.Activity + ( Activity(..) + , ActivityID(..) + , ActivityResult(..) + ) where + +import GHC.Generics + +-- | Type of the activity +-- +-- We don't have Activity_Unknown here +-- as we can do @Maybe Activity@ and @Nothing@ +-- corresponding to Unknown (which has 0 value) +-- +-- Rest of the values are offset by @(+100)@ +-- on the wire, i.e.: +-- +-- * @Activity_CopyPath = 100@ +-- * @Activity_BuildWaiting = 111@ +data Activity + = Activity_CopyPath + | Activity_FileTransfer + | Activity_Realise + | Activity_CopyPaths + | Activity_Builds + | Activity_Build + | Activity_OptimiseStore + | Activity_VerifyPaths + | Activity_Substitute + | Activity_QueryPathInfo + | Activity_PostBuildHook + | Activity_BuildWaiting + deriving (Bounded, Eq, Enum, Generic, Ord, Show) + +-- | Numeric ID of the activity +newtype ActivityID = ActivityID { unActivityID :: Int } + deriving (Eq, Generic, Ord, Show) + +-- | Result of some activity +-- +-- The values are offset by @(+100)@ +-- on the wire, i.e.: +-- +-- * @ActivityResult_FileLinked = 100@ +-- * @ActivityResult_PostBuildLogLine = 107@ +data ActivityResult + = ActivityResult_FileLinked + | ActivityResult_BuildLogLine + | ActivityResult_UnstrustedPath + | ActivityResult_CorruptedPath + | ActivityResult_SetPhase + | ActivityResult_Progress + | ActivityResult_SetExpected + | ActivityResult_PostBuildLogLine + deriving (Bounded, Eq, Enum, Generic, Ord, Show) diff --git a/src/System/Nix/Store/Remote/Types/CheckMode.hs b/src/System/Nix/Store/Remote/Types/CheckMode.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Types/CheckMode.hs @@ -0,0 +1,11 @@ +module System.Nix.Store.Remote.Types.CheckMode + ( CheckMode(..) + ) where + +import GHC.Generics + +-- | Check mode, used by @verifyStore@ +data CheckMode + = CheckMode_DoCheck + | CheckMode_DontCheck + deriving (Bounded, Eq, Generic, Enum, Ord, Show) diff --git a/src/System/Nix/Store/Remote/Types/GC.hs b/src/System/Nix/Store/Remote/Types/GC.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Types/GC.hs @@ -0,0 +1,55 @@ +{-| +Description : Garbage collection actions / options +Maintainer : srk +|-} +module System.Nix.Store.Remote.Types.GC ( + GCAction(..) + , GCOptions(..) + , GCResult(..) + , GCRoot(..) + ) where + +import Data.HashSet (HashSet) +import Data.Word (Word64) +import GHC.Generics (Generic) +import System.Nix.StorePath (StorePath) +import System.Posix.ByteString (RawFilePath) + +-- | Garbage collection action +data GCAction + = GCAction_ReturnLive -- ^ Return the set of paths reachable from roots (closure) + | GCAction_ReturnDead -- ^ Return unreachable paths + | GCAction_DeleteDead -- ^ Delete unreachable paths + | GCAction_DeleteSpecific -- ^ Delete specified paths + deriving (Bounded, Eq, Enum, Generic, Ord, Show) + +-- | Garbage collector operation options +data GCOptions = GCOptions + { -- | Operation + gcOptionsOperation :: GCAction + -- | If set, then reachability from the roots is ignored (unused) + , gcOptionsIgnoreLiveness :: Bool + -- | Paths to delete for @GCAction_DeleteSpecific@ + , gcOptionsPathsToDelete :: HashSet StorePath + -- | Stop after `gcOptions_maxFreed` bytes have been freed + , gcOptionsMaxFreed :: Word64 + } deriving (Eq, Generic, Ord, Show) + +-- | Result of the garbage collection operation +data GCResult = GCResult + { -- | Depending on the action, the GC roots, + -- or the paths that would be or have been deleted + gcResultDeletedPaths :: HashSet StorePath + -- | The number of bytes that would be or was freed for + -- + -- - @GCAction_ReturnDead@ + -- - @GCAction_DeleteDead@ + -- - @GCAction_DeleteSpecific@ + , gcResultBytesFreed :: Word64 + } deriving (Eq, Generic, Ord, Show) + +-- | Used as a part of the result of @FindRoots@ operation +data GCRoot + = GCRoot_Censored -- ^ Source path is censored since the user is not trusted + | GCRoot_Path RawFilePath -- ^ Raw source path + deriving (Eq, Generic, Ord, Show) diff --git a/src/System/Nix/Store/Remote/Types/Handshake.hs b/src/System/Nix/Store/Remote/Types/Handshake.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Types/Handshake.hs @@ -0,0 +1,37 @@ +module System.Nix.Store.Remote.Types.Handshake + ( ClientHandshakeInput(..) + , ClientHandshakeOutput(..) + , ServerHandshakeInput(..) + , ServerHandshakeOutput(..) + ) where + +import Data.Text (Text) +import GHC.Generics (Generic) +import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion) +import System.Nix.Store.Remote.Types.TrustedFlag (TrustedFlag) + +-- | 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) + +-- | Data received by the client via initial protocol handshake +data ClientHandshakeOutput = ClientHandshakeOutput + { clientHandshakeOutputNixVersion :: Maybe Text -- ^ Textual version, since 1.33 + , 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) + +-- | 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) + +-- | 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) diff --git a/src/System/Nix/Store/Remote/Types/Logger.hs b/src/System/Nix/Store/Remote/Types/Logger.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Types/Logger.hs @@ -0,0 +1,108 @@ +module System.Nix.Store.Remote.Types.Logger + ( Field(..) + , Trace(..) + , BasicError(..) + , ErrorInfo(..) + , Logger(..) + , LoggerOpCode(..) + , loggerOpCodeToWord64 + , word64ToLoggerOpCode + , isError + ) where + +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Word (Word64) +import GHC.Generics +import System.Nix.Store.Remote.Types.Activity (Activity, ActivityID, ActivityResult) +import System.Nix.Store.Remote.Types.Verbosity (Verbosity) + +data Field + = Field_LogStr Text + | Field_LogInt Int + deriving (Eq, Generic, Ord, Show) + +-- | Error trace +data Trace = Trace + { tracePosition :: Maybe Int -- Error position, Nix always writes 0 here + , traceHint :: Text + } + 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 + , errorInfoPosition :: Maybe Int -- Error position, Nix always writes 0 here + , errorInfoTraces :: [Trace] + } + deriving (Eq, Generic, Ord, Show) + +data LoggerOpCode + = LoggerOpCode_Next + | LoggerOpCode_Read + | LoggerOpCode_Write + | LoggerOpCode_Last + | LoggerOpCode_Error + | LoggerOpCode_StartActivity + | LoggerOpCode_StopActivity + | LoggerOpCode_Result + deriving (Eq, Generic, Ord, Show) + +loggerOpCodeToWord64 :: LoggerOpCode -> Word64 +loggerOpCodeToWord64 = \case + LoggerOpCode_Next -> 0x6f6c6d67 + LoggerOpCode_Read -> 0x64617461 + LoggerOpCode_Write -> 0x64617416 + LoggerOpCode_Last -> 0x616c7473 + LoggerOpCode_Error -> 0x63787470 + LoggerOpCode_StartActivity -> 0x53545254 + LoggerOpCode_StopActivity -> 0x53544f50 + LoggerOpCode_Result -> 0x52534c54 + +word64ToLoggerOpCode :: Word64 -> Either String LoggerOpCode +word64ToLoggerOpCode = \case + 0x6f6c6d67 -> Right LoggerOpCode_Next + 0x64617461 -> Right LoggerOpCode_Read + 0x64617416 -> Right LoggerOpCode_Write + 0x616c7473 -> Right LoggerOpCode_Last + 0x63787470 -> Right LoggerOpCode_Error + 0x53545254 -> Right LoggerOpCode_StartActivity + 0x53544f50 -> Right LoggerOpCode_StopActivity + 0x52534c54 -> Right LoggerOpCode_Result + x -> Left $ "Invalid LoggerOpCode: " ++ show x + +data Logger + = Logger_Next Text + | Logger_Read Word64 -- data needed from source + | Logger_Write ByteString -- data for sink + | Logger_Last + | Logger_Error (Either BasicError ErrorInfo) + | Logger_StartActivity + { startActivityID :: ActivityID + , startActivityVerbosity :: Verbosity + , startActivityType :: Maybe Activity + , startActivityString :: ByteString + , startActivityFields :: [Field] + , startActivityParentID :: ActivityID + } + | Logger_StopActivity + { stopActivityID :: ActivityID + } + | Logger_Result + { resultActivityID :: ActivityID + , resultType :: ActivityResult + , resultFields :: [Field] + } + deriving (Eq, Generic, Ord, Show) + +isError :: Logger -> Bool +isError Logger_Error {} = True +isError _ = False diff --git a/src/System/Nix/Store/Remote/Types/NoReply.hs b/src/System/Nix/Store/Remote/Types/NoReply.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Types/NoReply.hs @@ -0,0 +1,8 @@ +module System.Nix.Store.Remote.Types.NoReply + ( NoReply(..) + ) where + +-- | Reply type for the case where the server does not reply +data NoReply = NoReply + deriving (Show) + diff --git a/src/System/Nix/Store/Remote/Types/ProtoVersion.hs b/src/System/Nix/Store/Remote/Types/ProtoVersion.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Types/ProtoVersion.hs @@ -0,0 +1,27 @@ +module System.Nix.Store.Remote.Types.ProtoVersion + ( ProtoVersion(..) + , HasProtoVersion(..) + ) where + +import Data.Default.Class (Default(def)) +import Data.Word (Word8, Word16) +import GHC.Generics (Generic) + +data ProtoVersion = ProtoVersion + { protoVersion_major :: Word16 + , protoVersion_minor :: Word8 + } + deriving (Eq, Generic, Ord, Show) + +-- | The protocol version we support +instance Default ProtoVersion where + def = ProtoVersion + { protoVersion_major = 1 + , protoVersion_minor = 24 + } + +class HasProtoVersion r where + hasProtoVersion :: r -> ProtoVersion + +instance HasProtoVersion ProtoVersion where + hasProtoVersion = id diff --git a/src/System/Nix/Store/Remote/Types/Query.hs b/src/System/Nix/Store/Remote/Types/Query.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Types/Query.hs @@ -0,0 +1,5 @@ +module System.Nix.Store.Remote.Types.Query + ( module System.Nix.Store.Remote.Types.Query.Missing + ) where + +import System.Nix.Store.Remote.Types.Query.Missing diff --git a/src/System/Nix/Store/Remote/Types/Query/Missing.hs b/src/System/Nix/Store/Remote/Types/Query/Missing.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Types/Query/Missing.hs @@ -0,0 +1,18 @@ +module System.Nix.Store.Remote.Types.Query.Missing + ( Missing(..) + ) where + +import Data.HashSet (HashSet) +import Data.Word (Word64) +import GHC.Generics (Generic) +import System.Nix.StorePath (StorePath) + +-- | Result of @QueryMissing@ @StoreRequest@ +data Missing = Missing + { missingWillBuild :: HashSet StorePath -- ^ Paths that will be built + , missingWillSubstitute :: HashSet StorePath -- ^ Paths that can be substituted from cache + , missingUnknownPaths :: HashSet StorePath -- ^ Path w/o any information + , missingDownloadSize :: Word64 -- ^ Total size of packed NARs to download + , missingNarSize :: Word64 -- ^ Total size of NARs after unpacking + } + deriving (Eq, Generic, Ord, Show) diff --git a/src/System/Nix/Store/Remote/Types/StoreConfig.hs b/src/System/Nix/Store/Remote/Types/StoreConfig.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Types/StoreConfig.hs @@ -0,0 +1,61 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module System.Nix.Store.Remote.Types.StoreConfig + ( ProtoStoreConfig(..) + , StoreSocketPath(..) + , StoreTCP(..) + , StoreConnection(..) + , HasStoreSocket(..) + ) where + +import Data.Default.Class (Default(def)) +import Data.String (IsString) +import GHC.Generics (Generic) +import Network.Socket (Socket) +import System.Nix.StorePath (HasStoreDir(..), StoreDir) +import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion) + +class HasStoreSocket r where + hasStoreSocket :: r -> Socket + +instance HasStoreSocket Socket where + hasStoreSocket = id + +data ProtoStoreConfig = ProtoStoreConfig + { protoStoreConfigDir :: StoreDir + , protoStoreConfigProtoVersion :: ProtoVersion + } deriving (Eq, Generic, Ord, Show) + +instance Default ProtoStoreConfig where + def = ProtoStoreConfig def def + +instance HasStoreDir StoreDir where + hasStoreDir = id + +instance HasStoreDir ProtoStoreConfig where + hasStoreDir = protoStoreConfigDir + +instance HasProtoVersion ProtoStoreConfig where + hasProtoVersion = protoStoreConfigProtoVersion + +newtype StoreSocketPath = StoreSocketPath + { unStoreSocketPath :: FilePath + } + deriving newtype (IsString) + deriving stock (Eq, Generic, Ord, Show) + +instance Default StoreSocketPath where + def = StoreSocketPath "/nix/var/nix/daemon-socket/socket" + +data StoreTCP = StoreTCP + { storeTCPHost :: String + , storeTCPPort :: Int + } deriving (Eq, Generic, Ord, Show) + +data StoreConnection + = StoreConnection_Socket StoreSocketPath + | StoreConnection_TCP StoreTCP + deriving (Eq, Generic, Ord, Show) + +instance Default StoreConnection where + def = StoreConnection_Socket def diff --git a/src/System/Nix/Store/Remote/Types/StoreReply.hs b/src/System/Nix/Store/Remote/Types/StoreReply.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Types/StoreReply.hs @@ -0,0 +1,61 @@ +module System.Nix.Store.Remote.Types.StoreReply + ( StoreReply(..) + ) where + +import Data.HashSet (HashSet) +import Data.Map (Map) +import System.Nix.Build (BuildResult) +import System.Nix.StorePath (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.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 +-- we have a serializer for but we mostly need +-- 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 + +instance StoreReply SuccessCodeReply where + getReplyS = opSuccess + +instance StoreReply NoReply where + getReplyS = noop NoReply + +instance StoreReply Bool where + getReplyS = mapPrimE bool + +instance StoreReply BuildResult where + getReplyS = buildResult + +instance StoreReply GCResult where + getReplyS = gcResult + +instance StoreReply (Map GCRoot StorePath) where + getReplyS = mapS gcRoot (mapPrimE storePath) + +instance StoreReply Missing where + getReplyS = missing + +instance StoreReply (Maybe (Metadata StorePath)) where + getReplyS = maybePathMetadata + +instance StoreReply StorePath where + getReplyS = mapPrimE storePath + +instance StoreReply (HashSet StorePath) where + getReplyS = mapPrimE (hashSet storePath) + +instance StoreReply (HashSet StorePathName) where + getReplyS = mapPrimE (hashSet storePathName) + +mapPrimE + :: NixSerializer r SError a + -> NixSerializer r 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 new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Types/StoreRequest.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TemplateHaskell #-} + +module System.Nix.Store.Remote.Types.StoreRequest + ( StoreRequest(..) + ) where + +import Data.GADT.Compare.TH (deriveGEq, deriveGCompare) +import Data.GADT.Show.TH (deriveGShow) +import Data.HashSet (HashSet) +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.Hash (HashAlgo) +import System.Nix.Signature (Signature) +import System.Nix.Store.Types (FileIngestionMethod, RepairMode) +import System.Nix.StorePath (StorePath, StorePathName, StorePathHashPart) +import System.Nix.StorePath.Metadata (Metadata) +import System.Nix.Store.Remote.Types.GC (GCOptions, GCResult, GCRoot) +import System.Nix.Store.Remote.Types.CheckMode (CheckMode) +import System.Nix.Store.Remote.Types.NoReply (NoReply) +import System.Nix.Store.Remote.Types.Query.Missing (Missing) +import System.Nix.Store.Remote.Types.StoreText (StoreText) +import System.Nix.Store.Remote.Types.SubstituteMode (SubstituteMode) +import System.Nix.Store.Remote.Types.SuccessCodeReply (SuccessCodeReply) + +data StoreRequest :: Type -> Type where + -- | 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 + -> StoreRequest StorePath + + -- | Add a NAR with Metadata to the store. + AddToStoreNar + :: StorePath + -> Metadata StorePath + -> RepairMode + -> CheckMode -- ^ Whether to check signatures + -> StoreRequest NoReply + + -- | Add text to store. + -- + -- Reference accepts repair but only uses it + -- to throw error in case of remote talking to nix-daemon. + AddTextToStore + :: StoreText + -> HashSet StorePath -- ^ Set of @StorePath@s that the added text references + -> RepairMode -- ^ Repair mode, must be @RepairMode_DontRepair@ in case of remote backend + -> StoreRequest StorePath + + AddSignatures + :: StorePath + -> Set Signature + -> StoreRequest SuccessCodeReply + + AddIndirectRoot + :: StorePath + -> StoreRequest SuccessCodeReply + + -- | Add temporary garbage collector root. + -- + -- This root is removed as soon as the client exits. + AddTempRoot + :: StorePath + -> StoreRequest SuccessCodeReply + + -- | Build paths if they are an actual derivations. + -- + -- If derivation output paths are already valid, do nothing. + BuildPaths + :: Set DerivedPath + -> BuildMode + -> StoreRequest SuccessCodeReply + + BuildDerivation + :: StorePath + -> Derivation StorePath Text + -> BuildMode + -> StoreRequest BuildResult + + CollectGarbage + :: GCOptions + -> StoreRequest GCResult + + EnsurePath + :: StorePath + -> StoreRequest SuccessCodeReply + + -- | Find garbage collector roots. + FindRoots + :: StoreRequest (Map GCRoot StorePath) + + IsValidPath + :: StorePath + -> StoreRequest Bool + + -- | Fetch a NAR from the server + NarFromPath + :: StorePath + -> StoreRequest NoReply + + -- | Query valid paths from set, optionally try to use substitutes. + QueryValidPaths + :: HashSet StorePath + -- ^ Set of @StorePath@s to query + -> SubstituteMode + -- ^ Try substituting missing paths when @SubstituteMode_DoSubstitute@ + -> StoreRequest (HashSet StorePath) + + QueryAllValidPaths + :: StoreRequest (HashSet StorePath) + + QuerySubstitutablePaths + :: HashSet StorePath + -> StoreRequest (HashSet StorePath) + + QueryPathInfo + :: StorePath + -> StoreRequest (Maybe (Metadata StorePath)) + + QueryReferrers + :: StorePath + -> StoreRequest (HashSet StorePath) + + QueryValidDerivers + :: StorePath + -> StoreRequest (HashSet StorePath) + + QueryDerivationOutputs + :: StorePath + -> StoreRequest (HashSet StorePath) + + QueryDerivationOutputNames + :: StorePath + -> StoreRequest (HashSet StorePathName) + + QueryPathFromHashPart + :: StorePathHashPart + -> StoreRequest StorePath + + QueryMissing + :: Set DerivedPath + -> StoreRequest Missing + + OptimiseStore + :: StoreRequest SuccessCodeReply + + SyncWithGC + :: StoreRequest SuccessCodeReply + + -- returns True on errors + VerifyStore + :: CheckMode + -> RepairMode + -> StoreRequest Bool + +deriving instance Eq (StoreRequest a) +deriving instance Show (StoreRequest a) + +deriveGEq ''StoreRequest +deriveGCompare ''StoreRequest +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 (AddToStoreNar a b c d) == Some (AddToStoreNar a' b' c' d') = (a, b, c, d) == (a', b', c', d') + 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' + Some (AddTempRoot a) == Some (AddTempRoot a') = a == a' + Some (BuildPaths a b) == Some (BuildPaths a' b') = (a, b) == (a', b') + Some (BuildDerivation a b c) == Some (BuildDerivation a' b' c') = (a, b, c) == (a', b', c') + Some (CollectGarbage a) == Some (CollectGarbage a') = a == a' + Some (EnsurePath a) == Some (EnsurePath a') = a == a' + Some (FindRoots) == Some (FindRoots) = True + Some (IsValidPath a) == Some (IsValidPath a') = a == a' + Some (NarFromPath a) == Some (NarFromPath a') = a == a' + Some (QueryValidPaths a b) == Some (QueryValidPaths a' b') = (a, b) == (a', b') + Some QueryAllValidPaths == Some QueryAllValidPaths = True + Some (QuerySubstitutablePaths a) == Some (QuerySubstitutablePaths a') = a == a' + Some (QueryPathInfo a) == Some (QueryPathInfo a') = a == a' + Some (QueryReferrers a) == Some (QueryReferrers a') = a == a' + Some (QueryValidDerivers a) == Some (QueryValidDerivers a') = a == a' + Some (QueryDerivationOutputs a) == Some (QueryDerivationOutputs a') = a == a' + Some (QueryDerivationOutputNames a) == Some (QueryDerivationOutputNames a') = a == a' + Some (QueryPathFromHashPart a) == Some (QueryPathFromHashPart a') = a == a' + Some (QueryMissing a) == Some (QueryMissing a') = a == a' + Some OptimiseStore == Some OptimiseStore = True + Some SyncWithGC == Some SyncWithGC = True + Some (VerifyStore a b) == Some (VerifyStore a' b') = (a, b) == (a', b') + + _ == _ = False diff --git a/src/System/Nix/Store/Remote/Types/StoreText.hs b/src/System/Nix/Store/Remote/Types/StoreText.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Types/StoreText.hs @@ -0,0 +1,12 @@ +module System.Nix.Store.Remote.Types.StoreText + ( StoreText(..) + ) where + +import Data.Text (Text) +import GHC.Generics (Generic) +import System.Nix.StorePath (StorePathName) + +data StoreText = StoreText + { storeTextName :: StorePathName + , storeTextText :: Text + } deriving (Eq, Generic, Ord, Show) diff --git a/src/System/Nix/Store/Remote/Types/SubstituteMode.hs b/src/System/Nix/Store/Remote/Types/SubstituteMode.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Types/SubstituteMode.hs @@ -0,0 +1,11 @@ +module System.Nix.Store.Remote.Types.SubstituteMode + ( SubstituteMode(..) + ) where + +import GHC.Generics + +-- | Path substitution mode, used by @queryValidPaths@ +data SubstituteMode + = SubstituteMode_DoSubstitute + | SubstituteMode_DontSubstitute + deriving (Bounded, Eq, Generic, Enum, Ord, Show) diff --git a/src/System/Nix/Store/Remote/Types/SuccessCodeReply.hs b/src/System/Nix/Store/Remote/Types/SuccessCodeReply.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Types/SuccessCodeReply.hs @@ -0,0 +1,10 @@ +module System.Nix.Store.Remote.Types.SuccessCodeReply + ( SuccessCodeReply(..) + ) where + +import GHC.Generics (Generic) + +-- | Reply that checks an int success return value +data SuccessCodeReply = SuccessCodeReply + deriving (Eq, Show, Generic) + diff --git a/src/System/Nix/Store/Remote/Types/TrustedFlag.hs b/src/System/Nix/Store/Remote/Types/TrustedFlag.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Types/TrustedFlag.hs @@ -0,0 +1,11 @@ +module System.Nix.Store.Remote.Types.TrustedFlag + ( TrustedFlag(..) + ) where + +import GHC.Generics (Generic) + +-- | Whether remote side trust us +data TrustedFlag + = TrustedFlag_Trusted + | TrustedFlag_NotTrusted + deriving (Bounded, Eq, Generic, Enum, Ord, Show) diff --git a/src/System/Nix/Store/Remote/Types/Verbosity.hs b/src/System/Nix/Store/Remote/Types/Verbosity.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Types/Verbosity.hs @@ -0,0 +1,17 @@ +module System.Nix.Store.Remote.Types.Verbosity + ( Verbosity(..) + ) where + +import GHC.Generics + +-- | Logging verbosity +data Verbosity + = Verbosity_Error + | Verbosity_Warn + | Verbosity_Notice + | Verbosity_Info + | Verbosity_Talkative + | Verbosity_Chatty + | Verbosity_Debug + | Verbosity_Vomit + deriving (Bounded, Eq, Enum, Generic, Ord, Show) diff --git a/src/System/Nix/Store/Remote/Types/WorkerMagic.hs b/src/System/Nix/Store/Remote/Types/WorkerMagic.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Types/WorkerMagic.hs @@ -0,0 +1,27 @@ +module System.Nix.Store.Remote.Types.WorkerMagic + ( WorkerMagic(..) + , workerMagicToWord64 + , word64ToWorkerMagic + ) where + +import Data.Word (Word64) +import GHC.Generics (Generic) + +-- | WorkerMagic +-- +-- Magic numbers exchange during handshake +data WorkerMagic + = WorkerMagic_One + | WorkerMagic_Two + deriving (Eq, Generic, Ord, Show) + +workerMagicToWord64 :: WorkerMagic -> Word64 +workerMagicToWord64 = \case + WorkerMagic_One -> 0x6e697863 + WorkerMagic_Two -> 0x6478696f + +word64ToWorkerMagic :: Word64 -> Either String WorkerMagic +word64ToWorkerMagic = \case + 0x6e697863 -> Right WorkerMagic_One + 0x6478696f -> Right WorkerMagic_Two + x -> Left $ "Invalid WorkerMagic: " ++ show x diff --git a/src/System/Nix/Store/Remote/Types/WorkerOp.hs b/src/System/Nix/Store/Remote/Types/WorkerOp.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Types/WorkerOp.hs @@ -0,0 +1,59 @@ +module System.Nix.Store.Remote.Types.WorkerOp + ( WorkerOp(..) + ) where + +import GHC.Generics (Generic) + +-- | Worker opcode +-- +-- This type has gaps filled in so that the GHC builtin +-- Enum instance lands on the right values. +data WorkerOp + = WorkerOp_Reserved_0__ -- 0 + | WorkerOp_IsValidPath -- 1 + | WorkerOp_Reserved_2__ -- 2 + | WorkerOp_HasSubstitutes -- 3 + | WorkerOp_QueryPathHash -- 4 // obsolete + | WorkerOp_QueryReferences -- 5 // obsolete + | WorkerOp_QueryReferrers -- 6 + | WorkerOp_AddToStore -- 7 + | WorkerOp_AddTextToStore -- 8 // obsolete since 1.25, Nix 3.0. Use wopAddToStore + | WorkerOp_BuildPaths -- 9 + | WorkerOp_EnsurePath -- 10 0xa + | WorkerOp_AddTempRoot -- 11 0xb + | WorkerOp_AddIndirectRoot -- 12 0xc + | WorkerOp_SyncWithGC -- 13 0xd + | WorkerOp_FindRoots -- 14 0xe + | WorkerOp_Reserved_15__ -- 15 0xf + | WorkerOp_ExportPath -- 16 0x10 // obsolete + | WorkerOp_Reserved_17__ -- 17 0x11 + | WorkerOp_QueryDeriver -- 18 0x12 // obsolete + | WorkerOp_SetOptions -- 19 0x13 + | WorkerOp_CollectGarbage -- 20 0x14 + | WorkerOp_QuerySubstitutablePathInfo -- 21 0x15 + | WorkerOp_QueryDerivationOutputs -- 22 0x16 // obsolete + | WorkerOp_QueryAllValidPaths -- 23 0x17 + | WorkerOp_QueryFailedPaths -- 24 0x18 + | WorkerOp_ClearFailedPaths -- 25 0x19 + | WorkerOp_QueryPathInfo -- 26 0x1a + | WorkerOp_ImportPaths -- 27 0x1b // obsolete + | WorkerOp_QueryDerivationOutputNames -- 28 0x1c // obsolete + | WorkerOp_QueryPathFromHashPart -- 29 0x1d + | WorkerOp_QuerySubstitutablePathInfos -- 30 0x1e + | WorkerOp_QueryValidPaths -- 31 0x1f + | WorkerOp_QuerySubstitutablePaths -- 32 0x20 + | WorkerOp_QueryValidDerivers -- 33 0x21 + | WorkerOp_OptimiseStore -- 34 0x22 + | WorkerOp_VerifyStore -- 35 0x23 + | WorkerOp_BuildDerivation -- 36 0x24 + | WorkerOp_AddSignatures -- 37 0x25 + | WorkerOp_NarFromPath -- 38 0x26 + | WorkerOp_AddToStoreNar -- 39 0x27 + | WorkerOp_QueryMissing -- 40 0x28 + | WorkerOp_QueryDerivationOutputMap -- 41 0x29 + | WorkerOp_RegisterDrvOutput -- 42 0x2a + | WorkerOp_QueryRealisation -- 43 0x2b + | WorkerOp_AddMultipleToStore -- 44 0x2c + | WorkerOp_AddBuildLog -- 45 0x2d + | WorkerOp_BuildPathsWithResults -- 46 0x2e + deriving (Bounded, Eq, Enum, Generic, Ord, Show, Read) diff --git a/src/System/Nix/Store/Remote/Util.hs b/src/System/Nix/Store/Remote/Util.hs deleted file mode 100644 --- a/src/System/Nix/Store/Remote/Util.hs +++ /dev/null @@ -1,167 +0,0 @@ -{-# language RecordWildCards #-} -module System.Nix.Store.Remote.Util where - -import Prelude hiding ( putText ) -import Control.Monad.Except - -import Data.Binary.Get -import Data.Binary.Put -import qualified Data.Text.Lazy.Encoding as TL -import Data.Time -import Data.Time.Clock.POSIX -import qualified Data.ByteString.Char8 as BSC -import qualified Data.ByteString.Lazy as BSL - -import Network.Socket.ByteString ( recv - , sendAll - ) - -import Nix.Derivation - -import System.Nix.Build -import System.Nix.StorePath -import System.Nix.Store.Remote.Binary -import System.Nix.Store.Remote.Types - -import qualified Data.HashSet -import qualified Data.Map - -genericIncremental :: (MonadIO m) => m (Maybe ByteString) -> Get a -> m a -genericIncremental getsome parser = go decoder - where - decoder = runGetIncremental parser - go (Done _leftover _consumed x ) = pure x - go (Partial k ) = do - chunk <- getsome - go (k chunk) - go (Fail _leftover _consumed msg) = error $ fromString msg - -getSocketIncremental :: Get a -> MonadStore a -getSocketIncremental = genericIncremental sockGet8 - where - sockGet8 :: MonadStore (Maybe BSC.ByteString) - sockGet8 = do - soc <- asks storeSocket - liftIO $ Just <$> recv soc 8 - -sockPut :: Put -> MonadStore () -sockPut p = do - soc <- asks storeSocket - liftIO $ sendAll soc $ toStrict $ runPut p - -sockGet :: Get a -> MonadStore a -sockGet = getSocketIncremental - -sockGetInt :: Integral a => MonadStore a -sockGetInt = getSocketIncremental getInt - -sockGetBool :: MonadStore Bool -sockGetBool = (== (1 :: Int)) <$> sockGetInt - -sockGetStr :: MonadStore ByteString -sockGetStr = getSocketIncremental getByteStringLen - -sockGetStrings :: MonadStore [ByteString] -sockGetStrings = getSocketIncremental getByteStrings - -sockGetPath :: MonadStore StorePath -sockGetPath = do - sd <- getStoreDir - pth <- getSocketIncremental (getPath sd) - either - throwError - pure - pth - -sockGetPathMay :: MonadStore (Maybe StorePath) -sockGetPathMay = do - sd <- getStoreDir - pth <- getSocketIncremental (getPath sd) - pure $ - either - (const Nothing) - Just - pth - -sockGetPaths :: MonadStore StorePathSet -sockGetPaths = do - sd <- getStoreDir - getSocketIncremental (getPaths sd) - -bsToText :: ByteString -> Text -bsToText = decodeUtf8 - -textToBS :: Text -> ByteString -textToBS = encodeUtf8 - -bslToText :: BSL.ByteString -> Text -bslToText = toText . TL.decodeUtf8 - -textToBSL :: Text -> BSL.ByteString -textToBSL = TL.encodeUtf8 . toLText - -putText :: Text -> Put -putText = putByteStringLen . textToBSL - -putTexts :: [Text] -> Put -putTexts = putByteStrings . fmap textToBSL - -getPath :: FilePath -> Get (Either String StorePath) -getPath sd = parsePath sd <$> getByteStringLen - -getPaths :: FilePath -> Get StorePathSet -getPaths sd = - Data.HashSet.fromList . rights . fmap (parsePath sd) <$> getByteStrings - -putPath :: StorePath -> Put -putPath = putByteStringLen . fromStrict . storePathToRawFilePath - -putPaths :: StorePathSet -> Put -putPaths = putByteStrings . Data.HashSet.toList . Data.HashSet.map - (fromStrict . storePathToRawFilePath) - -putBool :: Bool -> Put -putBool True = putInt (1 :: Int) -putBool False = putInt (0 :: Int) - -getBool :: Get Bool -getBool = (== 1) <$> (getInt :: Get Int) - -putEnum :: (Enum a) => a -> Put -putEnum = putInt . fromEnum - -getEnum :: (Enum a) => Get a -getEnum = toEnum <$> getInt - -putTime :: UTCTime -> Put -putTime = (putInt :: Int -> Put) . round . utcTimeToPOSIXSeconds - -getTime :: Get UTCTime -getTime = posixSecondsToUTCTime <$> getEnum - -getBuildResult :: Get BuildResult -getBuildResult = - BuildResult - <$> getEnum - <*> (Just . bsToText <$> getByteStringLen) - <*> getInt - <*> getBool - <*> getTime - <*> getTime - -putDerivation :: Derivation StorePath Text -> Put -putDerivation Derivation{..} = do - flip putMany (Data.Map.toList outputs) - $ \(outputName, DerivationOutput{..}) -> do - putText outputName - putPath path - putText hashAlgo - putText hash - - putMany putPath inputSrcs - putText platform - putText builder - putMany putText args - - flip putMany (Data.Map.toList env) - $ \(a1, a2) -> putText a1 *> putText a2 diff --git a/tests-io/DataSink.hs b/tests-io/DataSink.hs new file mode 100644 --- /dev/null +++ b/tests-io/DataSink.hs @@ -0,0 +1,26 @@ +module DataSink + +( DataSink(..) +, dataSinkResult +, dataSinkWriter +, newDataSink +) + +where + +import Data.ByteString (ByteString) + +import Control.Monad.ST +import Data.STRef + +-- | Basic data sink for testing +newtype DataSink = DataSink (STRef RealWorld ByteString) + +newDataSink :: IO DataSink +newDataSink = DataSink <$> (stToIO . newSTRef) mempty + +dataSinkWriter :: DataSink -> (ByteString -> IO()) +dataSinkWriter (DataSink stref) chunk = stToIO (modifySTRef stref (chunk <>)) + +dataSinkResult :: DataSink -> IO ByteString +dataSinkResult (DataSink stref) = (stToIO . readSTRef) stref diff --git a/tests-io/Main.hs b/tests-io/Main.hs new file mode 100644 --- /dev/null +++ b/tests-io/Main.hs @@ -0,0 +1,12 @@ +module Main where + +import qualified Test.Hspec +import qualified NixDaemonSpec + +-- we run remote tests in +-- Linux namespaces to avoid interacting with systems store +main :: IO () +main = do + NixDaemonSpec.enterNamespaces + Test.Hspec.hspec + NixDaemonSpec.spec diff --git a/tests-io/NixDaemonSpec.hs b/tests-io/NixDaemonSpec.hs new file mode 100644 --- /dev/null +++ b/tests-io/NixDaemonSpec.hs @@ -0,0 +1,521 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} + +module NixDaemonSpec + ( enterNamespaces + , spec + ) where + +import Control.Exception (catch, SomeException) +import Control.Monad (forM_, unless, void) +import Control.Monad.Catch (MonadMask) +import Control.Monad.Conc.Class (MonadConc) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Crypto.Hash (SHA256) +import Data.Some (Some(Some)) +import Data.Text (Text) +import Test.Hspec (ActionWith, Spec, SpecWith, around, describe, context) +import Test.Hspec.Expectations.Lifted +import Test.Hspec.Nix (forceRight) +import System.FilePath (()) +import System.Linux.Namespaces (Namespace(..), GroupMapping(..), UserMapping(..)) +import System.Nix.Hash (HashAlgo(HashAlgo_SHA256)) +import System.Nix.Build (BuildMode(..)) +import System.Nix.DerivedPath (DerivedPath(..)) +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 + +createProcessEnv + :: FilePath + -> CreateProcess + -> IO ProcessHandle +createProcessEnv fp cp = do + mPath <- System.Environment.lookupEnv "PATH" + + (_, _, _, ph) <- + System.Process.createProcess cp + { cwd = Just fp + , env = Just $ mockedEnv mPath fp + } + pure ph + +mockedEnv + :: Maybe String + -> FilePath + -> [(String, FilePath)] +mockedEnv mEnvPath fp = + [ ("NIX_STORE_DIR" , fp "store") + , ("NIX_LOCALSTATE_DIR", fp "var") + , ("NIX_LOG_DIR" , fp "var" "log") + , ("NIX_STATE_DIR" , fp "var" "nix") + , ("NIX_CONF_DIR" , fp "etc") + , ("HOME" , fp "home") +-- , ("NIX_REMOTE", "daemon") + ] <> foldMap (\x -> [("PATH", x)]) mEnvPath + +waitSocket + :: FilePath + -> Int + -> IO () +waitSocket _ 0 = fail "No socket" +waitSocket fp x = do + ex <- System.Directory.doesFileExist fp + unless ex $ do + Control.Concurrent.threadDelay 100000 + waitSocket fp (x - 1) + +writeConf :: FilePath -> IO () +writeConf fp = + writeFile fp $ unlines + [ "build-users-group = " + , "trusted-users = root" + , "allowed-users = *" + , "fsync-metadata = false" + ] + +{- + - we run in user namespace as root but groups are failed + - => build-users-group has to be empty but we still + - get an error (maybe older nix-daemon) + - +uid=0(root) gid=65534(nobody) groups=65534(nobody) + +drwxr-xr-x 3 0 65534 60 Nov 29 05:53 store + +accepted connection from pid 22959, user root (trusted) +error: changing ownership of path '/run/user/1000/test-nix-store-06b0d249e5616122/store': Invalid argument +-} + +startDaemon + :: FilePath -- ^ Temporary directory + -> IO (ProcessHandle, StoreConnection) +startDaemon fp = do + writeConf (fp "etc" "nix.conf") + procHandle <- + createProcessEnv + fp + $ System.Process.proc "nix-daemon" mempty + + waitSocket sockFp 30 + pure ( procHandle + , StoreConnection_Socket + $ StoreSocketPath sockFp + ) + where + sockFp = fp "var/nix/daemon-socket/socket" + +enterNamespaces :: IO () +enterNamespaces = do + uid <- System.Posix.User.getEffectiveUserID + gid <- System.Posix.User.getEffectiveGroupID + + System.Linux.Namespaces.unshare + [User, Network, Mount] + + -- fmap our (parent) uid to root + System.Linux.Namespaces.writeUserMappings + Nothing + [ UserMapping + 0 -- inside namespace + uid -- outside namespace + 1 --range + ] + + -- fmap our (parent) gid to root group + System.Linux.Namespaces.writeGroupMappings + Nothing + [ GroupMapping 0 gid 1 ] + True + +withNixDaemon' + :: (FilePath -> StoreDir -> StoreConnection -> IO a) + -> IO a +withNixDaemon' action = + System.IO.Temp.withSystemTempDirectory "test-nix-store" $ \path -> do + + mapM_ (System.Directory.createDirectory . snd) + (filter + ((/= "NIX_REMOTE") . fst) + $ mockedEnv Nothing path) + + ini <- + createProcessEnv + path + $ System.Process.shell + -- see long note above @startDaemon@ + "nix-store --init 2>&1 | grep -v 'error: changing ownership'" + + void $ System.Process.waitForProcess ini + + writeFile (path "dummy") "Hello World" + + System.Directory.setCurrentDirectory path + let storeDir = + StoreDir + $ Data.ByteString.Char8.pack + $ path "store" + + Control.Exception.bracket + (startDaemon path) + (System.Process.terminateProcess . fst) + (action path storeDir . snd) + +withNixDaemon + :: ( MonadIO m + , MonadMask m + ) + => ((RemoteStoreT m a -> Run m a) -> IO a) + -> IO a +withNixDaemon action = + withNixDaemon' $ \_tmpPath storeDir storeConn -> + action $ \(mstore :: RemoteStoreT m a) -> + runStoreConnection storeConn + ( setStoreDir storeDir + >> mstore + ) + +withManInTheMiddleNixDaemon + :: forall m a + . ( MonadIO m + , MonadMask m + , MonadConc m + ) + => ((RemoteStoreT m a -> Run m a) -> IO a) + -> IO a +withManInTheMiddleNixDaemon action = + withNixDaemon' $ \tmpPath storeDir storeConn -> + let + sockFp2 = tmpPath "var/nix/daemon-socket/socket2" + storeConn2 = StoreConnection_Socket $ StoreSocketPath sockFp2 + + handler :: WorkerHelper m + handler = + runStoreConnection storeConn + . (setStoreDir storeDir >>) + + in action $ \(mstore :: RemoteStoreT m a) -> + runDaemonConnection handler + (setStoreDir storeDir) + storeConn2 + $ runStoreConnection storeConn2 + ( setStoreDir storeDir + >> mstore + ) + +checks + :: ( Show a + , Show b + ) + => IO (a, b) + -> (a -> Bool) + -> IO () +checks action check = + action >>= (`Test.Hspec.shouldSatisfy` (check . fst)) + +it + :: (Show a, Show b, Monad m) + => String + -> m c + -> (a -> Bool) + -> SpecWith (m () -> IO (a, b)) +it name action check = + Test.Hspec.it name $ \run -> run (void $ action) `checks` check + +itRights + :: ( Show a + , Show b + , Show c + , Monad m + ) + => String + -> m d + -> SpecWith (m () -> IO (Either a b, c)) +itRights name action = it name action Data.Either.isRight + +itLefts + :: ( Show a + , Show b + , Show c + , Monad m + ) + => String + -> m d + -> SpecWith (m () -> IO (Either a b, c)) +itLefts name action = it name action Data.Either.isLeft + +sampleText :: Text +sampleText = "test" + +withPath + :: MonadRemoteStore m + => (StorePath -> m a) + -> m a +withPath action = do + path <- + addTextToStore + (StoreText + (forceRight $ System.Nix.StorePath.mkStorePathName "hnix-store") + sampleText + ) + mempty + RepairMode_DontRepair + action path + +-- | dummy path, adds /dummy with "Hello World" contents +dummy :: MonadRemoteStore m => m StorePath +dummy = do + addToStore + (forceRight $ System.Nix.StorePath.mkStorePathName "dummy") + (System.Nix.Nar.dumpPath "dummy") + FileIngestionMethod_Flat + (Some HashAlgo_SHA256) + RepairMode_DontRepair + +invalidPath :: StorePath +invalidPath = + let name = forceRight $ System.Nix.StorePath.mkStorePathName "invalid" + in System.Nix.StorePath.unsafeMakeStorePath + (System.Nix.StorePath.mkStorePathHashPart + @SHA256 + "invalid") + name + +_withBuilder + :: MonadRemoteStore m + => (StorePath -> m a) + -> m a +_withBuilder action = do + path <- + addTextToStore + (StoreText + (forceRight $ System.Nix.StorePath.mkStorePathName "builder") + builderSh + ) + mempty + RepairMode_DontRepair + action path + +builderSh :: Text +builderSh = "declare -xpexport > $out" + +spec :: Spec +spec = do + describe "Remote store protocol" $ do + describe "Direct" + $ makeProtoSpec + withNixDaemon + SpecFlavor_Direct + describe "MITM" + $ makeProtoSpec + withManInTheMiddleNixDaemon + SpecFlavor_MITM + +data SpecFlavor + = SpecFlavor_Direct + | SpecFlavor_MITM + deriving (Eq, Ord, Show) + +makeProtoSpec + :: (ActionWith + (RemoteStoreT IO () -> Run IO ()) + -> IO () + ) + -> SpecFlavor + -> Spec +makeProtoSpec f flavor = around f $ do + + context "syncWithGC" $ + itRights "syncs with garbage collector" syncWithGC + + context "verifyStore" $ do + itRights "check=False repair=False" $ + verifyStore + CheckMode_DontCheck + RepairMode_DontRepair + `shouldReturn` False + + itRights "check=True repair=False" $ + verifyStore + CheckMode_DoCheck + RepairMode_DontRepair + `shouldReturn` False + + --privileged + itRights "check=True repair=True" $ + verifyStore + CheckMode_DoCheck + RepairMode_DoRepair + `shouldReturn` False + + context "addTextToStore" $ + itRights "adds text to store" $ withPath pure + + context "isValidPath" $ do + itRights "validates path" $ withPath $ \path -> do + isValidPath path `shouldReturn` True + + itLefts "fails on invalid path" $ do + setStoreDir (StoreDir "/asdf") + isValidPath invalidPath + + context "queryAllValidPaths" $ do + itRights "empty query" queryAllValidPaths + itRights "non-empty query" $ withPath $ \path -> + queryAllValidPaths `shouldReturn` Data.HashSet.fromList [path] + + context "queryPathInfo" $ + itRights "queries path info" $ withPath $ \path -> do + meta <- queryPathInfo path + (metadataReferences <$> meta) `shouldBe` (Just mempty) + + context "ensurePath" $ + itRights "simple ensure" $ withPath ensurePath + + context "addTempRoot" $ + itRights "simple addition" $ withPath addTempRoot + + context "addIndirectRoot" $ + itRights "simple addition" $ withPath addIndirectRoot + + let toDerivedPathSet p = Data.Set.fromList [DerivedPath_Opaque p] + + context "buildPaths" $ do + itRights "build Normal" $ withPath $ \path -> do + buildPaths (toDerivedPathSet path) BuildMode_Normal + + itRights "build Check" $ withPath $ \path -> do + buildPaths (toDerivedPathSet path) BuildMode_Check + + itLefts "build Repair" $ withPath $ \path -> do + buildPaths (toDerivedPathSet path) BuildMode_Repair + + context "roots" $ context "findRoots" $ do + itRights "empty roots" (findRoots `shouldReturn` mempty) + + itRights "path added as a temp root" $ withPath $ \_ -> do + let expectRoots = + if flavor == SpecFlavor_MITM + then 0 -- nested client closes its connection so temp root gets removed + else 1 + roots <- findRoots + roots `shouldSatisfy` ((== expectRoots) . Data.Map.size) + + itRights "indirect root" $ withPath $ \path -> do + let expectRoots = + if flavor == SpecFlavor_MITM + then 1 -- nested client closes its connection so temp root gets removed + else 2 + addIndirectRoot path + roots <- findRoots + roots `shouldSatisfy` ((== expectRoots) . Data.Map.size) + + context "optimiseStore" $ itRights "optimises" optimiseStore + + context "queryMissing" $ + itRights "queries" $ withPath $ \path -> do + queryMissing (toDerivedPathSet path) + `shouldReturn` + Missing + { missingWillBuild = mempty + , missingWillSubstitute = mempty + , missingUnknownPaths = mempty + , missingDownloadSize = 0 + , missingNarSize = 0 + } + + context "addToStore" $ + itRights "adds file to store" $ do + fp <- + liftIO + $ System.IO.Temp.writeSystemTempFile + "addition" + "yolo" + + addToStore + (forceRight $ System.Nix.StorePath.mkStorePathName "tmp-addition") + (System.Nix.Nar.dumpPath fp) + FileIngestionMethod_Flat + (Some HashAlgo_SHA256) + RepairMode_DontRepair + + context "with dummy" $ do + itRights "adds dummy" dummy + + itRights "valid dummy" $ do + path <- dummy + isValidPath path `shouldReturn` True + + context "collectGarbage" $ do + itRights "deletes a specific path from the store" $ withPath $ \path -> do + -- clear temp gc roots so the delete works. restarting the nix daemon should also do this... + storeDir <- getStoreDir + let tempRootsDir = Data.Text.unpack $ mconcat [ Data.Text.Encoding.decodeUtf8 (unStoreDir storeDir), "/../var/nix/temproots/" ] + liftIO $ do + tempRootList <- + System.Directory.listDirectory tempRootsDir + forM_ tempRootList $ \entry -> do + System.Directory.removeFile + $ mconcat [ tempRootsDir, "/", entry ] + -- for MITM, the temp root will get deleted + -- by the daemon as our nested client exists + -- but the listDirectory might still see it + -- causing TOC/TOU flakiness + `catch` (\(_e :: SomeException) -> pure ()) + + GCResult{..} <- + collectGarbage + GCOptions + { gcOptionsOperation = GCAction_DeleteSpecific + , gcOptionsIgnoreLiveness = False + , gcOptionsPathsToDelete = Data.HashSet.fromList [path] + , gcOptionsMaxFreed = maxBound + } + gcResultDeletedPaths `shouldBe` Data.HashSet.fromList [path] + gcResultBytesFreed `shouldBe` 4 + + context "addToStoreNar" $ do + itRights "adds nar file" $ do + unless (flavor == SpecFlavor_MITM) $ do + sampleNar@SampleNar.SampleNar{..} <- liftIO SampleNar.sampleNar0 + dataSource <- liftIO $ SampleNar.buildDataSource sampleNar + addToStoreNar sampleNar_storePath sampleNar_metadata RepairMode_DontRepair CheckMode_DontCheck dataSource + + meta <- queryPathInfo sampleNar_storePath + (metadataDeriverPath =<< meta) `shouldBe` metadataDeriverPath sampleNar_metadata + + context "narFromPath" $ do + itRights "downloads nar file" $ do + unless (flavor == SpecFlavor_MITM) $ do + withPath $ \path -> do + maybeMetadata <- queryPathInfo path + case maybeMetadata of + Just Metadata{metadataNarBytes=Just narBytes} -> do + dataSink <- liftIO DataSink.newDataSink + narFromPath path narBytes (DataSink.dataSinkWriter dataSink) + narData <- liftIO $ DataSink.dataSinkResult dataSink + expectedNarData <- liftIO $ SampleNar.encodeNar (Data.Text.Encoding.encodeUtf8 sampleText) + narData `shouldBe` expectedNarData + _ -> expectationFailure "missing metadata or narBytes" diff --git a/tests-io/SampleNar.hs b/tests-io/SampleNar.hs new file mode 100644 --- /dev/null +++ b/tests-io/SampleNar.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} + +module SampleNar + +( SampleNar(..) +, buildDataSource +, sampleNar0 +, encodeNar +) + +where + +import Crypto.Hash ( Digest, SHA256, hashInit, hashUpdate, hashFinalize ) +import Data.ByteString (ByteString) +import Data.Dependent.Sum (DSum((:=>))) +import Data.Time.Calendar.OrdinalDate (fromOrdinalDate) +import Data.Time.Clock (UTCTime(..)) +import System.Nix.Hash (HashAlgo(HashAlgo_SHA256)) +import System.Nix.StorePath (StorePath, parsePath) +import System.Nix.StorePath.Metadata (Metadata(..), StorePathTrust(..)) + +import Control.Monad.ST +import Data.Default.Class +import Data.STRef +import Data.Word + +import qualified Data.ByteString +import qualified System.Nix.Nar + +-- | Sample data for an AddToStoreNar operation +data SampleNar + = SampleNar + { sampleNar_fileData :: !ByteString -- ^ Contents of the file to be put in the store + , sampleNar_narData :: !ByteString -- ^ The file data serialized as a NAR + , sampleNar_storePath :: !StorePath + , sampleNar_metadata :: !(Metadata StorePath) + } + +sampleNar0 :: IO SampleNar +sampleNar0 = do + let sampleNar_fileData = "hello" + sampleNar_narData <- encodeNar sampleNar_fileData + let sampleNar_metadata = Metadata + { metadataDeriverPath = Just $ forceParsePath "/nix/store/g2mxdrkwr1hck4y5479dww7m56d1x81v-hello-2.12.1.drv" + , metadataNarHash = sha256 sampleNar_narData + , metadataReferences = mempty + , metadataRegistrationTime = UTCTime (fromOrdinalDate 1980 1) 0 + , metadataNarBytes = Just ((fromIntegral . Data.ByteString.length) sampleNar_narData) + , metadataTrust = BuiltElsewhere + , metadataSigs = mempty + , metadataContentAddress = Nothing + } + sampleNar_storePath = forceParsePath "/nix/store/00000lj3clbkc0aqvjjzfa6slp4zdvlj-hello-2.12.1" + pure SampleNar{..} + +buildDataSource :: SampleNar -> IO(Word64 -> IO (Maybe ByteString)) +buildDataSource SampleNar{sampleNar_narData} = dataSourceFromByteString sampleNar_narData + +dataSourceFromByteString :: ByteString -> IO (Word64 -> IO(Maybe ByteString)) +dataSourceFromByteString bs = do + posRef <- stToIO $ newSTRef (0::Word64) + let len = fromIntegral $ Data.ByteString.length bs + outFn chunkSize = do + pos <- stToIO $ readSTRef posRef + if pos >= len then pure Nothing + else do + let bs' = Data.ByteString.drop (fromIntegral pos) bs + bs'' = Data.ByteString.take (fromIntegral chunkSize) bs' + takenLen = fromIntegral $ Data.ByteString.length bs'' + stToIO $ modifySTRef posRef (takenLen +) + pure $ Just bs'' + pure outFn + +forceParsePath :: ByteString -> StorePath +forceParsePath path = case parsePath def path of + Left err -> error $ mconcat [ "forceParsePath failed: ", show err ] + Right x -> x +sha256 :: ByteString -> DSum HashAlgo Digest +sha256 bs = HashAlgo_SHA256 :=> hashFinalize (hashUpdate (hashInit @SHA256) bs) + +encodeNar :: ByteString -> IO ByteString +encodeNar bytes = do + ref <- stToIO $ newSTRef mempty + let accumFn chunk = do + stToIO $ modifySTRef ref (<> chunk) + System.Nix.Nar.dumpString bytes accumFn + stToIO $ readSTRef ref + diff --git a/tests/Data/SerializerSpec.hs b/tests/Data/SerializerSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/SerializerSpec.hs @@ -0,0 +1,43 @@ +module Data.SerializerSpec (spec) where + +import Data.Some +import Data.Serializer +import Data.Serializer.Example + +import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Hspec.QuickCheck (prop) + +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)) + `shouldBe` + Left MyPutError_NoLongerSupported + + it "Handles getS error" $ + runG cmdSGetError (runPutSimple cmdS (Some (Cmd_Bool True))) + `shouldBe` + Left (SerializerError_Get MyGetError_Example) + + it "Handles getS fail" $ + runG cmdSGetFail (runPutSimple cmdS (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)) + `shouldBe` + ((pure $ pure $ someCmd) :: + Either MyPutError + (Either (GetSerializerError MyGetError) + (Some Cmd))) diff --git a/tests/Driver.hs b/tests/Driver.hs --- a/tests/Driver.hs +++ b/tests/Driver.hs @@ -1,9 +1,1 @@ -import NixDaemon -import qualified Spec - --- we run remote tests in --- Linux namespaces to avoid interacting with systems store -main :: IO () -main = do - enterNamespaces - Spec.main +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/tests/EnumSpec.hs b/tests/EnumSpec.hs new file mode 100644 --- /dev/null +++ b/tests/EnumSpec.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE OverloadedStrings #-} + +module EnumSpec (spec) where + +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 + ( activity + , activityResult + , enum + , int + , loggerOpCode + , runP + , LoggerSError + , NixSerializer + , SError + ) +import System.Nix.Store.Remote.Types + +spec :: Spec +spec = do + let + itE + :: ( Bounded a + , Enum a + , Show a + ) + => String + -> a + -> Word64 + -> SpecWith () + itE name constr value = + it name + $ ((runP enum () constr) :: Either SError ByteString) + `shouldBe` + (runP (int @Word64) () value) + + itE' + :: Show a + => NixSerializer () LoggerSError a + -> String + -> a + -> Word64 + -> SpecWith () + itE' s name constr value = + it name + $ ((runP s () constr) :: Either LoggerSError ByteString) + `shouldBe` + (runP (int @Word64) () (value)) + + describe "Enums" $ do + describe "BuildMode enum order matches Nix" $ do + itE "Normal" BuildMode_Normal 0 + 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 "GCAction enum order matches Nix" $ do + itE "ReturnLive" GCAction_ReturnLive 0 + itE "ReturnDead" GCAction_ReturnDead 1 + itE "DeleteDead" GCAction_DeleteDead 2 + itE "DeleteSpecific" GCAction_DeleteSpecific 3 + + describe "Logger" $ do + let itA = itE' activity + describe "Activity enum order matches Nix" $ do + itA "CopyPath" Activity_CopyPath 100 + itA "FileTransfer" Activity_FileTransfer 101 + itA "Realise" Activity_Realise 102 + itA "CopyPaths" Activity_CopyPaths 103 + itA "Builds" Activity_Builds 104 + itA "Build" Activity_Build 105 + itA "OptimiseStore" Activity_OptimiseStore 106 + itA "VerifyPaths" Activity_VerifyPaths 107 + itA "Substitute" Activity_Substitute 108 + itA "QueryPathInfo" Activity_QueryPathInfo 109 + itA "PostBuildHook" Activity_PostBuildHook 110 + itA "BuildWaiting" Activity_BuildWaiting 111 + + let itR = itE' activityResult + describe "ActivityResult enum order matches Nix" $ do + itR "FileLinked" ActivityResult_FileLinked 100 + itR "BuildLogLine" ActivityResult_BuildLogLine 101 + itR "UnstrustedPath" ActivityResult_UnstrustedPath 102 + itR "CorruptedPath" ActivityResult_CorruptedPath 103 + itR "SetPhase" ActivityResult_SetPhase 104 + itR "Progress" ActivityResult_Progress 105 + itR "SetExpected" ActivityResult_SetExpected 106 + itR "PostBuildLogLine" ActivityResult_PostBuildLogLine 107 + + + let itL = itE' loggerOpCode + describe "LoggerOpCode matches Nix" $ do + itL "Next" LoggerOpCode_Next 0x6f6c6d67 + itL "Read" LoggerOpCode_Read 0x64617461 + itL "Write" LoggerOpCode_Write 0x64617416 + itL "Last" LoggerOpCode_Last 0x616c7473 + itL "Error" LoggerOpCode_Error 0x63787470 + itL "StartActivity" LoggerOpCode_StartActivity 0x53545254 + itL "StopActivity" LoggerOpCode_StopActivity 0x53544f50 + itL "Result" LoggerOpCode_Result 0x52534c54 + + describe "Verbosity enum order matches Nix" $ do + itE "Error" Verbosity_Error 0 + itE "Warn" Verbosity_Warn 1 + itE "Notice" Verbosity_Notice 2 + itE "Info" Verbosity_Info 3 + itE "Talkative" Verbosity_Talkative 4 + itE "Chatty" Verbosity_Chatty 5 + itE "Debug" Verbosity_Debug 6 + itE "Vomit" Verbosity_Vomit 7 + + describe "WorkerOp enum order matches Nix" $ do + itE "IsValidPath" WorkerOp_IsValidPath 1 + itE "BuildPathsWithResults" WorkerOp_BuildPathsWithResults 46 + + + diff --git a/tests/NixDaemon.hs b/tests/NixDaemon.hs deleted file mode 100644 --- a/tests/NixDaemon.hs +++ /dev/null @@ -1,262 +0,0 @@ -{-# language DataKinds #-} -{-# language ScopedTypeVariables #-} - -module NixDaemon where - -import qualified System.Environment as Env -import Control.Exception ( bracket ) -import Control.Concurrent ( threadDelay ) -import qualified Data.HashSet as HS -import qualified Data.Map.Strict as M -import System.Directory -import System.IO.Temp -import qualified System.Process as P -import System.Posix.User as U -import System.Linux.Namespaces as NS -import Test.Hspec ( Spec - , describe - , context - ) -import qualified Test.Hspec as Hspec -import Test.Hspec.Expectations.Lifted - -import System.FilePath - -import System.Nix.Build -import System.Nix.StorePath -import System.Nix.Store.Remote -import System.Nix.Store.Remote.Protocol - -import Crypto.Hash ( SHA256 ) -import System.Nix.Nar ( dumpPath ) - -createProcessEnv :: FilePath -> String -> [String] -> IO P.ProcessHandle -createProcessEnv fp proc args = do - mPath <- Env.lookupEnv "PATH" - - (_, _, _, ph) <- - P.createProcess (P.proc proc args) - { P.cwd = Just fp - , P.env = Just $ mockedEnv mPath fp - } - pure ph - -mockedEnv :: Maybe String -> FilePath -> [(String, FilePath)] -mockedEnv mEnvPath fp = (fp ) <<$>> - [ ("NIX_STORE_DIR" , "store") - , ("NIX_LOCALSTATE_DIR", "var") - , ("NIX_LOG_DIR" , "var" "log") - , ("NIX_STATE_DIR" , "var" "nix") - , ("NIX_CONF_DIR" , "etc") - , ("HOME" , "home") --- , ("NIX_REMOTE", "daemon") - ] <> foldMap (\x -> [("PATH", x)]) mEnvPath - -waitSocket :: FilePath -> Int -> IO () -waitSocket _ 0 = fail "No socket" -waitSocket fp x = do - ex <- doesFileExist fp - bool - (threadDelay 100000 >> waitSocket fp (x - 1)) - pass - ex - -writeConf :: FilePath -> IO () -writeConf fp = - writeFileText fp $ unlines - [ "build-users-group = " - , "trusted-users = root" - , "allowed-users = *" - , "fsync-metadata = false" - ] - -{- - - we run in user namespace as root but groups are failed - - => build-users-group has to be empty but we still - - get an error (maybe older nix-daemon) - - -uid=0(root) gid=65534(nobody) groups=65534(nobody) - -drwxr-xr-x 3 0 65534 60 Nov 29 05:53 store - -accepted connection from pid 22959, user root (trusted) -error: changing ownership of path '/run/user/1000/test-nix-store-06b0d249e5616122/store': Invalid argument --} - -startDaemon - :: FilePath - -> IO (P.ProcessHandle, MonadStore a -> IO (Either String a, [Logger])) -startDaemon fp = do - writeConf (fp "etc" "nix.conf") - p <- createProcessEnv fp "nix-daemon" [] - waitSocket sockFp 30 - pure (p, runStoreOpts sockFp (fp "store")) - where - sockFp = fp "var/nix/daemon-socket/socket" - -enterNamespaces :: IO () -enterNamespaces = do - uid <- getEffectiveUserID - gid <- getEffectiveGroupID - - unshare [User, Network, Mount] - -- fmap our (parent) uid to root - writeUserMappings Nothing [UserMapping 0 uid 1] - -- fmap our (parent) gid to root group - writeGroupMappings Nothing [GroupMapping 0 gid 1] True - -withNixDaemon - :: ((MonadStore a -> IO (Either String a, [Logger])) -> IO a) -> IO a -withNixDaemon action = - withSystemTempDirectory "test-nix-store" $ \path -> do - - mapM_ (createDirectory . snd) - (filter ((/= "NIX_REMOTE") . fst) $ mockedEnv Nothing path) - - ini <- createProcessEnv path "nix-store" ["--init"] - void $ P.waitForProcess ini - - writeFile (path "dummy") "Hello World" - - setCurrentDirectory path - - bracket (startDaemon path) - (P.terminateProcess . fst) - (action . snd) - -checks :: (Show a, Show b) => IO (a, b) -> (a -> Bool) -> IO () -checks action check = action >>= (`Hspec.shouldSatisfy` (check . fst)) - -it - :: (Show a, Show b, Monad m) - => String - -> m c - -> (a -> Bool) - -> Hspec.SpecWith (m () -> IO (a, b)) -it name action check = - Hspec.it name $ \run -> run (action >> pass) `checks` check - -itRights - :: (Show a, Show b, Show c, Monad m) - => String - -> m d - -> Hspec.SpecWith (m () -> IO (Either a b, c)) -itRights name action = it name action isRight - -itLefts - :: (Show a, Show b, Show c, Monad m) - => String - -> m d - -> Hspec.SpecWith (m () -> IO (Either a b, c)) -itLefts name action = it name action isLeft - -withPath :: (StorePath -> MonadStore a) -> MonadStore a -withPath action = do - path <- addTextToStore "hnix-store" "test" (HS.fromList []) False - action path - --- | dummy path, adds /dummpy with "Hello World" contents -dummy :: MonadStore StorePath -dummy = do - let Right n = makeStorePathName "dummy" - addToStore @SHA256 n (dumpPath "dummy") False False - -invalidPath :: StorePath -invalidPath = - let Right n = makeStorePathName "invalid" - in StorePath (mkStorePathHashPart "invalid") n "no_such_root" - -withBuilder :: (StorePath -> MonadStore a) -> MonadStore a -withBuilder action = do - path <- addTextToStore "builder" builderSh (HS.fromList []) False - action path - -builderSh :: Text -builderSh = "declare -xpexport > $out" - -spec_protocol :: Spec -spec_protocol = Hspec.around withNixDaemon $ - - describe "store" $ do - - context "syncWithGC" $ - itRights "syncs with garbage collector" syncWithGC - - context "verifyStore" $ do - itRights "check=False repair=False" $ - verifyStore False False `shouldReturn` False - - itRights "check=True repair=False" $ - verifyStore True False `shouldReturn` False - - --privileged - itRights "check=True repair=True" $ - verifyStore True True `shouldReturn` False - - context "addTextToStore" $ - itRights "adds text to store" $ withPath pure - - context "isValidPathUncached" $ do - itRights "validates path" $ withPath $ \path -> do - liftIO $ print path - isValidPathUncached path `shouldReturn` True - itLefts "fails on invalid path" $ isValidPathUncached invalidPath - - context "queryAllValidPaths" $ do - itRights "empty query" queryAllValidPaths - itRights "non-empty query" $ withPath $ \path -> - queryAllValidPaths `shouldReturn` HS.fromList [path] - - context "queryPathInfoUncached" $ - itRights "queries path info" $ withPath queryPathInfoUncached - - context "ensurePath" $ - itRights "simple ensure" $ withPath ensurePath - - context "addTempRoot" $ - itRights "simple addition" $ withPath addTempRoot - - context "addIndirectRoot" $ - itRights "simple addition" $ withPath addIndirectRoot - - context "buildPaths" $ do - itRights "build Normal" $ withPath $ \path -> do - let pathSet = HS.fromList [path] - buildPaths pathSet Normal - - itRights "build Check" $ withPath $ \path -> do - let pathSet = HS.fromList [path] - buildPaths pathSet Check - - itLefts "build Repair" $ withPath $ \path -> do - let pathSet = HS.fromList [path] - buildPaths pathSet Repair - - context "roots" $ context "findRoots" $ do - itRights "empty roots" (findRoots `shouldReturn` M.empty) - - itRights "path added as a temp root" $ withPath $ \_ -> do - roots <- findRoots - roots `shouldSatisfy` ((== 1) . M.size) - - context "optimiseStore" $ itRights "optimises" optimiseStore - - context "queryMissing" $ - itRights "queries" $ withPath $ \path -> do - let pathSet = HS.fromList [path] - queryMissing pathSet `shouldReturn` (HS.empty, HS.empty, HS.empty, 0, 0) - - context "addToStore" $ - itRights "adds file to store" $ do - fp <- liftIO $ writeSystemTempFile "addition" "lal" - let Right n = makeStorePathName "tmp-addition" - res <- addToStore @SHA256 n (dumpPath fp) False False - liftIO $ print res - - context "with dummy" $ do - itRights "adds dummy" dummy - - itRights "valid dummy" $ do - path <- dummy - liftIO $ print path - isValidPathUncached path `shouldReturn` True diff --git a/tests/NixSerializerSpec.hs b/tests/NixSerializerSpec.hs new file mode 100644 --- /dev/null +++ b/tests/NixSerializerSpec.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE OverloadedStrings #-} + +module NixSerializerSpec (spec) where + +import Crypto.Hash (MD5, SHA1, SHA256, SHA512) +import Data.Some (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.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.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 + , Show a + , Eq e + , Show e + ) + => NixSerializer () e a + -> a + -> Expectation +roundtripS serializer = roundtripSReader serializer () + +spec :: Spec +spec = parallel $ do + describe "Prim" $ do + 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 + + describe "Combinators" $ do + prop "list" $ roundtripS @[Int] @() (list int) + prop "set" $ roundtripS (set byteString) + prop "hashSet" $ roundtripS (hashSet byteString) + prop "mapS" $ roundtripS (mapS (int @Int) byteString) + + 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 "StorePath" $ + roundtripSReader @StoreDir storePath + + prop "StorePathHashPart" $ + roundtripS storePathHashPart + + prop "StorePathName" $ + roundtripS storePathName + + prop "Metadata (StorePath)" $ + roundtripSReader @StoreDir pathMetadata + + prop "Some HashAlgo" $ + roundtripS someHashAlgo + + describe "Digest" $ do + prop "MD5" $ roundtripS . digest @MD5 + prop "SHA1" $ roundtripS . digest @SHA1 + prop "SHA256" $ roundtripS . digest @SHA256 + prop "SHA512" $ roundtripS . digest @SHA512 + + prop "Derivation" $ \sd -> + roundtripSReader @StoreDir derivation sd + . (\drv -> drv { inputDrvs = mempty }) + + prop "ProtoVersion" $ roundtripS @ProtoVersion @() protoVersion + + 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 + + describe "Handshake" $ do + prop "WorkerMagic" $ roundtripS workerMagic + prop "TrustedFlag" $ roundtripS trustedFlag + + describe "Worker protocol" $ do + prop "WorkerOp" $ roundtripS workerOp + prop "StoreText" $ roundtripS storeText + + prop "StoreRequest" + $ \testStoreConfig -> + forAll (arbitrary `suchThat` (restrictProtoVersion (hasProtoVersion testStoreConfig))) + $ roundtripSReader @ProtoStoreConfig storeRequest testStoreConfig + + describe "StoreReply" $ do + prop "()" $ roundtripS opSuccess + prop "GCResult" $ roundtripSReader @StoreDir gcResult + prop "GCRoot" $ roundtripS gcRoot + prop "Missing" $ roundtripSReader @StoreDir missing + prop "Maybe (Metadata StorePath)" $ roundtripSReader @StoreDir maybePathMetadata + +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 diff --git a/tests/Spec.hs b/tests/Spec.hs deleted file mode 100644 --- a/tests/Spec.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --generated-module=Spec #-} diff --git a/tests/Util.hs b/tests/Util.hs deleted file mode 100644 --- a/tests/Util.hs +++ /dev/null @@ -1,12 +0,0 @@ - -module Util where - -import Data.Text.Arbitrary () -import System.Nix.Store.Remote.Util -import Test.Tasty.QuickCheck - -prop_TextToBSLRoundtrip :: Text -> Property -prop_TextToBSLRoundtrip x = bslToText (textToBSL x) === x - -prop_TextToBSRoundtrip :: Text -> Property -prop_TextToBSRoundtrip x = bsToText (textToBS x) === x