hnix-store-remote 0.4.1.0 → 0.4.2.0
raw patch · 14 files changed
+454/−374 lines, 14 filesnew-uploaderPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ChangeLog.md +11/−0
- hnix-store-remote.cabal +3/−1
- src/System/Nix/Store/Remote.hs +109/−91
- src/System/Nix/Store/Remote/Binary.hs +10/−11
- src/System/Nix/Store/Remote/Builders.hs +17/−21
- src/System/Nix/Store/Remote/Logger.hs +50/−38
- src/System/Nix/Store/Remote/Parsers.hs +5/−4
- src/System/Nix/Store/Remote/Protocol.hs +65/−48
- src/System/Nix/Store/Remote/Types.hs +15/−10
- src/System/Nix/Store/Remote/Util.hs +52/−46
- tests/Derivation.hs +37/−29
- tests/Driver.hs +1/−1
- tests/NixDaemon.hs +77/−70
- tests/Util.hs +2/−4
ChangeLog.md view
@@ -1,5 +1,16 @@ # Revision history for hnix-store-remote +## [next](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
hnix-store-remote.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: hnix-store-remote-version: 0.4.1.0+version: 0.4.2.0 synopsis: Remote hnix store description: Implementation of the nix store using the daemon protocol. homepage: https://github.com/haskell-nix/hnix-store@@ -67,6 +67,8 @@ , Spec , Util hs-source-dirs: tests+ build-tool-depends:+ tasty-discover:tasty-discover build-depends: base , hnix-store-core >= 0.3 , hnix-store-remote
src/System/Nix/Store/Remote.hs view
@@ -7,8 +7,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-} module System.Nix.Store.Remote- (- addToStore+ ( addToStore , addTextToStore , addSignatures , addIndirectRoot@@ -34,18 +33,34 @@ , verifyStore , module System.Nix.Store.Remote.Types )- where+where -import Control.Monad (void, unless, when)-import Data.ByteString.Lazy (ByteString)-import Data.Map.Strict (Map)-import Data.Text (Text)+import Control.Monad ( void+ , unless+ , when+ )+import Data.ByteString.Lazy ( ByteString )+import Data.Map.Strict ( Map )+import Data.Text ( Text ) -import Nix.Derivation (Derivation)-import System.Nix.Build (BuildMode, BuildResult)-import System.Nix.Hash (Digest, NamedAlgo, ValidAlgo, SomeNamedDigest(..), BaseEncoding(Base32))-import System.Nix.StorePath (StorePath, StorePathName, StorePathSet, StorePathHashAlgo)-import System.Nix.StorePathMetadata (StorePathMetadata(..), StorePathTrust(..))+import Nix.Derivation ( Derivation )+import System.Nix.Build ( BuildMode+ , BuildResult+ )+import System.Nix.Hash ( Digest+ , NamedAlgo+ , ValidAlgo+ , SomeNamedDigest(..)+ , BaseEncoding(Base32)+ )+import System.Nix.StorePath ( StorePath+ , StorePathName+ , StorePathSet+ , StorePathHashAlgo+ )+import System.Nix.StorePathMetadata ( StorePathMetadata(..)+ , StorePathTrust(..)+ ) import qualified Data.Binary.Put import qualified Data.ByteString.Lazy@@ -68,22 +83,22 @@ type SubstituteFlag = Bool -- | Pack `FilePath` as `Nar` and add it to the store.-addToStore :: forall a. (ValidAlgo a, NamedAlgo a)- => StorePathName -- ^ Name part of the newly created `StorePath`- -> FilePath -- ^ Local `FilePath` to add- -> Bool -- ^ Add target directory recursively- -> (FilePath -> Bool) -- ^ Path filter function- -> RepairFlag -- ^ Only used by local store backend- -> MonadStore StorePath+addToStore+ :: forall a+ . (ValidAlgo a, NamedAlgo a)+ => StorePathName -- ^ Name part of the newly created `StorePath`+ -> FilePath -- ^ Local `FilePath` to add+ -> Bool -- ^ Add target directory recursively+ -> (FilePath -> Bool) -- ^ Path filter function+ -> RepairFlag -- ^ Only used by local store backend+ -> MonadStore StorePath addToStore name pth recursive _pathFilter _repair = do runOpArgsIO AddToStore $ \yield -> do yield $ Data.ByteString.Lazy.toStrict $ Data.Binary.Put.runPut $ do putText $ System.Nix.StorePath.unStorePathName name - putBool- $ not- $ System.Nix.Hash.algoName @a == "sha256" && recursive+ putBool $ not $ System.Nix.Hash.algoName @a == "sha256" && recursive putBool recursive @@ -97,22 +112,22 @@ -- -- 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+ :: 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"+ 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- -> [ByteString]- -> MonadStore ()+addSignatures :: StorePath -> [ByteString] -> MonadStore () addSignatures p signatures = do void $ simpleOpArgs AddSignatures $ do putPath p@@ -132,18 +147,17 @@ -- | Build paths if they are an actual derivations. -- -- If derivation output paths are already valid, do nothing.-buildPaths :: StorePathSet- -> BuildMode- -> MonadStore ()+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+ :: StorePath+ -> Derivation StorePath Text+ -> BuildMode+ -> MonadStore BuildResult buildDerivation p drv buildMode = do runOpArgs BuildDerivation $ do putPath p@@ -156,7 +170,7 @@ putInt 0 res <- getSocketIncremental $ getBuildResult- return res+ pure res ensurePath :: StorePath -> MonadStore () ensurePath pn = do@@ -166,30 +180,33 @@ findRoots :: MonadStore (Map ByteString StorePath) findRoots = do runOp FindRoots- sd <- getStoreDir- res <- getSocketIncremental+ sd <- getStoreDir+ res <-+ getSocketIncremental $ getMany- $ (,) <$> (Data.ByteString.Lazy.fromStrict <$> getByteStringLen) - <*> getPath sd+ $ (,)+ <$> (Data.ByteString.Lazy.fromStrict <$> getByteStringLen)+ <*> getPath sd r <- catRights res- return $ Data.Map.Strict.fromList r- where- catRights :: [(a, Either String b)] -> MonadStore [(a, b)]- catRights = mapM ex+ 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) = return (x, y)- ex (_x , Left e) = error $ "Unable to decode root: " ++ e+ ex :: (a, Either [Char] b) -> MonadStore (a, b)+ ex (x , Right y) = pure (x, y)+ ex (_x, Left e ) = error $ "Unable to decode root: " <> 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+ :: 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@@ -203,12 +220,10 @@ querySubstitutablePaths :: StorePathSet -> MonadStore StorePathSet querySubstitutablePaths ps = do- runOpArgs QuerySubstitutablePaths $ do- putPaths ps+ runOpArgs QuerySubstitutablePaths $ putPaths ps sockGetPaths -queryPathInfoUncached :: StorePath- -> MonadStore StorePathMetadata+queryPathInfoUncached :: StorePath -> MonadStore StorePathMetadata queryPathInfoUncached path = do runOpArgs QueryPathInfo $ do putPath path@@ -219,81 +234,84 @@ deriverPath <- sockGetPathMay narHashText <- Data.Text.Encoding.decodeUtf8 <$> sockGetStr- let narHash = case System.Nix.Hash.decodeBase @'System.Nix.Hash.SHA256 Base32 narHashText of- Left e -> error e+ let+ narHash =+ case+ System.Nix.Hash.decodeBase @'System.Nix.Hash.SHA256 Base32 narHashText+ of+ Left e -> error e Right x -> SomeDigest x - references <- sockGetPaths+ references <- sockGetPaths registrationTime <- sockGet getTime- narBytes <- Just <$> sockGetInt- ultimate <- sockGetBool+ narBytes <- Just <$> sockGetInt+ ultimate <- sockGetBool - _sigStrings <- map bsToText <$> sockGetStrings- caString <- sockGetStr+ _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 e+ case+ System.Nix.Store.Remote.Parsers.parseContentAddressableAddress caString+ of+ Left e -> error e Right x -> Just x - trust = if ultimate then BuiltLocally- else BuiltElsewhere+ trust = if ultimate then BuiltLocally else BuiltElsewhere - return $ StorePathMetadata {..}+ pure $ StorePathMetadata{..} queryReferrers :: StorePath -> MonadStore StorePathSet queryReferrers p = do- runOpArgs QueryReferrers $ do- putPath p+ runOpArgs QueryReferrers $ putPath p sockGetPaths queryValidDerivers :: StorePath -> MonadStore StorePathSet queryValidDerivers p = do- runOpArgs QueryValidDerivers $ do- putPath p+ runOpArgs QueryValidDerivers $ putPath p sockGetPaths queryDerivationOutputs :: StorePath -> MonadStore StorePathSet queryDerivationOutputs p = do- runOpArgs QueryDerivationOutputs $- putPath p+ runOpArgs QueryDerivationOutputs $ putPath p sockGetPaths queryDerivationOutputNames :: StorePath -> MonadStore StorePathSet queryDerivationOutputNames p = do- runOpArgs QueryDerivationOutputNames $- putPath p+ runOpArgs QueryDerivationOutputNames $ putPath p sockGetPaths queryPathFromHashPart :: Digest StorePathHashAlgo -> MonadStore StorePath queryPathFromHashPart storePathHash = do- runOpArgs QueryPathFromHashPart $- putByteStringLen- $ Data.ByteString.Lazy.fromStrict- $ Data.Text.Encoding.encodeUtf8- $ System.Nix.Hash.encodeInBase Base32 storePathHash+ runOpArgs QueryPathFromHashPart+ $ putByteStringLen+ $ Data.ByteString.Lazy.fromStrict+ $ Data.Text.Encoding.encodeUtf8+ $ System.Nix.Hash.encodeInBase Base32 storePathHash sockGetPath -queryMissing :: StorePathSet- -> MonadStore ( StorePathSet -- Paths that will be built- , StorePathSet -- Paths that have substitutes- , StorePathSet -- Unknown paths- , Integer -- Download size- , Integer) -- Nar size?+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 $ do- putPaths ps+ runOpArgs QueryMissing $ putPaths ps willBuild <- sockGetPaths willSubstitute <- sockGetPaths unknown <- sockGetPaths downloadSize' <- sockGetInt narSize' <- sockGetInt- return (willBuild, willSubstitute, unknown, downloadSize', narSize')+ pure (willBuild, willSubstitute, unknown, downloadSize', narSize') optimiseStore :: MonadStore () optimiseStore = void $ simpleOp OptimiseStore
src/System/Nix/Store/Remote/Binary.hs view
@@ -7,8 +7,8 @@ import Control.Monad import Data.Binary.Get import Data.Binary.Put-import Data.ByteString (ByteString)-import qualified Data.ByteString.Lazy as BSL+import Data.ByteString ( ByteString )+import qualified Data.ByteString.Lazy as BSL putInt :: Integral a => a -> Put putInt = putWord64le . fromIntegral@@ -31,12 +31,11 @@ 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 = sequence_ $ replicate count (putWord8 0)+ when (len `mod` 8 /= 0) $ pad $ 8 - (len `mod` 8)+ where+ len :: Int+ len = fromIntegral $ BSL.length x+ pad count = sequence_ $ replicate count (putWord8 0) putByteStrings :: Foldable t => t BSL.ByteString -> Put putByteStrings = putMany putByteStringLen@@ -44,11 +43,11 @@ getByteStringLen :: Get ByteString getByteStringLen = do len <- getInt- st <- getLazyByteString len+ 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)- return $ BSL.toStrict st+ unless (all (== 0) pads) $ fail $ "No zeroes" <> show (st, len, pads)+ pure $ BSL.toStrict st where unpad x = sequence $ replicate x getWord8 getByteStrings :: Get [ByteString]
src/System/Nix/Store/Remote/Builders.hs view
@@ -4,42 +4,38 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} -module System.Nix.Store.Remote.Builders (- buildContentAddressableAddress- ) where+module System.Nix.Store.Remote.Builders+ ( buildContentAddressableAddress+ )+where -import Data.Text.Lazy (Text)-import System.Nix.Hash ( Digest- , SomeNamedDigest(SomeDigest)- , BaseEncoding(Base32)- )-import System.Nix.StorePath (ContentAddressableAddress(..))+import Data.Text.Lazy ( Text )+import System.Nix.Hash ( Digest+ , SomeNamedDigest(SomeDigest)+ , BaseEncoding(Base32)+ )+import System.Nix.StorePath ( ContentAddressableAddress(..)+ ) -import Data.Text.Lazy.Builder (Builder)+import Data.Text.Lazy.Builder ( Builder ) import qualified Data.Text.Lazy.Builder import qualified System.Nix.Hash -- | Marshall `ContentAddressableAddress` to `Text` -- in form suitable for remote protocol usage.-buildContentAddressableAddress- :: ContentAddressableAddress- -> Text+buildContentAddressableAddress :: ContentAddressableAddress -> Text buildContentAddressableAddress = Data.Text.Lazy.Builder.toLazyText . contentAddressableAddressBuilder -contentAddressableAddressBuilder- :: ContentAddressableAddress- -> Builder+contentAddressableAddressBuilder :: ContentAddressableAddress -> Builder contentAddressableAddressBuilder (Text digest) =- "text:"- <> digestBuilder digest+ "text:" <> digestBuilder digest contentAddressableAddressBuilder (Fixed _narHashMode (SomeDigest (digest :: Digest hashAlgo))) =- "fixed:"+ "fixed:" <> (Data.Text.Lazy.Builder.fromText $ System.Nix.Hash.algoName @hashAlgo) <> digestBuilder digest digestBuilder :: Digest a -> Builder digestBuilder =- Data.Text.Lazy.Builder.fromText- . System.Nix.Hash.encodeInBase Base32+ Data.Text.Lazy.Builder.fromText . System.Nix.Hash.encodeInBase Base32
src/System/Nix/Store/Remote/Logger.hs view
@@ -1,21 +1,25 @@ {-# LANGUAGE RankNTypes #-}-module System.Nix.Store.Remote.Logger (- Logger(..)++module System.Nix.Store.Remote.Logger+ ( Logger(..) , Field(..)- , processOutput)- where+ , processOutput+ )+where + import Control.Monad.Except-import Control.Monad.Reader (ask)-import Control.Monad.State (get)+import Control.Monad.Reader ( asks )+import Control.Monad.State ( get ) import Data.Binary.Get -import Network.Socket.ByteString (recv)+import Network.Socket.ByteString ( recv ) import System.Nix.Store.Remote.Binary import System.Nix.Store.Remote.Types import System.Nix.Store.Remote.Util + controlParser :: Get Logger controlParser = do ctrl <- getInt@@ -24,43 +28,51 @@ 0x64617461 -> Read <$> getInt 0x64617416 -> Write <$> getByteStringLen 0x616c7473 -> pure Last- 0x63787470 -> flip Error <$> getByteStringLen <*> getInt- 0x53545254 -> StartActivity <$> getInt <*> getInt <*> getInt <*> getByteStringLen <*> getFields <*> getInt+ 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+ 0x52534c54 -> Result <$> getInt+ <*> getInt+ <*> getFields+ x -> fail $ "Invalid control message received:" <> show x 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 _ _) -> return [e]- Last -> return [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+ 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 - next <- go decoder- return $ next+ next <- go decoder+ pure next - -- we should probably handle Read here as well- x -> do- next <- go decoder- return $ x:next- go (Partial k) = do- soc <- storeSocket <$> ask- chunk <- liftIO (Just <$> recv soc 8)- go (k chunk)+ -- 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) - go (Fail _leftover _consumed msg) = do- error msg+ go (Fail _leftover _consumed msg) = error msg getFields :: Get [Field] getFields = do@@ -73,4 +85,4 @@ case (typ :: Int) of 0 -> LogInt <$> getInt 1 -> LogStr <$> getByteStringLen- x -> fail $ "Unknown log type: " ++ show x+ x -> fail $ "Unknown log type: " <> show x
src/System/Nix/Store/Remote/Parsers.hs view
@@ -13,7 +13,7 @@ import Control.Applicative ( (<|>) ) import Data.Attoparsec.ByteString.Char8 import Data.ByteString.Char8-import Data.Text (Text)+import Data.Text ( Text ) import Data.Text.Encoding ( decodeUtf8 ) import System.Nix.Hash import System.Nix.StorePath ( ContentAddressableAddress(..)@@ -35,7 +35,7 @@ caText = do _ <- "text:sha256:" digest <- decodeBase @'SHA256 Base32 <$> parseHash- either fail return $ Text <$> digest+ either fail pure $ Text <$> digest -- | Parser for @fixed:<r?>:<ht>:<h>@ caFixed :: Parser ContentAddressableAddress@@ -43,13 +43,14 @@ _ <- "fixed:" narHashMode <- (pure Recursive <$> "r:") <|> (pure RegularFile <$> "") digest <- parseTypedDigest- either fail return $ Fixed narHashMode <$> digest+ either fail pure $ Fixed narHashMode <$> digest parseTypedDigest :: Parser (Either String SomeNamedDigest) parseTypedDigest = mkNamedDigest <$> parseHashType <*> parseHash parseHashType :: Parser Text-parseHashType = decodeUtf8 <$> ("sha256" <|> "sha512" <|> "sha1" <|> "md5") <* (":" <|> "-")+parseHashType =+ decodeUtf8 <$> ("sha256" <|> "sha512" <|> "sha1" <|> "md5") <* (":" <|> "-") parseHash :: Parser Text parseHash = decodeUtf8 <$> takeWhile1 (/= ':')
src/System/Nix/Store/Remote/Protocol.hs view
@@ -1,17 +1,21 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}-module System.Nix.Store.Remote.Protocol (- WorkerOp(..)+module System.Nix.Store.Remote.Protocol+ ( WorkerOp(..) , simpleOp , simpleOpArgs , runOp , runOpArgs , runOpArgsIO , runStore- , runStoreOpts) where+ , runStoreOpts+ )+where -import Control.Exception (bracket)++import Data.Bool ( bool )+import Control.Exception ( bracket ) import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State@@ -22,15 +26,18 @@ import qualified Data.ByteString.Char8 import qualified Data.ByteString.Lazy -import Network.Socket (SockAddr(SockAddrUnix))+import Network.Socket ( SockAddr(SockAddrUnix) ) import qualified Network.Socket-import Network.Socket.ByteString (recv, sendAll)+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@@ -115,37 +122,42 @@ simpleOp :: WorkerOp -> MonadStore Bool-simpleOp op = do- simpleOpArgs op $ return ()+simpleOp op = simpleOpArgs op $ pure () simpleOpArgs :: WorkerOp -> Put -> MonadStore Bool simpleOpArgs op args = do runOpArgs op args err <- gotError- case err of- True -> do+ bool+ sockGetBool+ (do Error _num msg <- head <$> getError throwError $ Data.ByteString.Char8.unpack msg- False -> do- sockGetBool+ )+ err runOp :: WorkerOp -> MonadStore ()-runOp op = runOpArgs op $ return ()+runOp op = runOpArgs op $ pure () runOpArgs :: WorkerOp -> Put -> MonadStore ()-runOpArgs op args = runOpArgsIO op (\encode -> encode $ Data.ByteString.Lazy.toStrict $ runPut args)+runOpArgs op args =+ runOpArgsIO+ op+ (\encode -> encode $ Data.ByteString.Lazy.toStrict $ runPut args) -runOpArgsIO :: WorkerOp -> ((Data.ByteString.ByteString -> MonadStore ()) -> MonadStore ()) -> MonadStore ()+runOpArgsIO+ :: WorkerOp+ -> ((Data.ByteString.ByteString -> MonadStore ()) -> MonadStore ())+ -> MonadStore () runOpArgsIO op encoder = do - sockPut $ do- putInt $ opNum op+ sockPut $ putInt $ opNum op - soc <- storeSocket <$> ask+ soc <- asks storeSocket encoder (liftIO . sendAll soc) out <- processOutput- modify (\(a, b) -> (a, b++out))+ modify (\(a, b) -> (a, b <> out)) err <- gotError when err $ do Error _num msg <- head <$> getError@@ -154,39 +166,44 @@ runStore :: MonadStore a -> IO (Either String a, [Logger]) runStore = runStoreOpts defaultSockPath "/nix/store" -runStoreOpts :: FilePath -> FilePath -> MonadStore a -> IO (Either String a, [Logger])+runStoreOpts+ :: FilePath -> FilePath -> MonadStore a -> IO (Either String a, [Logger]) runStoreOpts sockPath storeRootDir code = do bracket (open sockPath) (Network.Socket.close . storeSocket) run- where- open path = do- soc <-- Network.Socket.socket- Network.Socket.AF_UNIX- Network.Socket.Stream- 0+ where+ open path = do+ soc <-+ Network.Socket.socket+ Network.Socket.AF_UNIX+ Network.Socket.Stream+ 0 - Network.Socket.connect soc (SockAddrUnix path)- return $ StoreConfig { storeSocket = soc- , storeDir = storeRootDir }+ Network.Socket.connect soc (SockAddrUnix path)+ pure StoreConfig+ { storeSocket = soc+ , storeDir = storeRootDir+ } - greet = do- sockPut $ putInt workerMagic1- soc <- storeSocket <$> ask- vermagic <- liftIO $ recv soc 16- let (magic2, _daemonProtoVersion) =- flip runGet (Data.ByteString.Lazy.fromStrict vermagic)- $ (,) <$> (getInt :: Get Int)- <*> (getInt :: Get Int)- unless (magic2 == workerMagic2) $ error "Worker magic 2 mismatch"+ greet = do+ sockPut $ putInt workerMagic1+ soc <- asks storeSocket+ vermagic <- liftIO $ recv soc 16+ let+ (magic2, _daemonProtoVersion) =+ flip runGet (Data.ByteString.Lazy.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+ sockPut $ putInt protoVersion -- clientVersion+ sockPut $ putInt (0 :: Int) -- affinity+ sockPut $ putInt (0 :: Int) -- obsolete reserveSpace - processOutput+ processOutput - run sock =- fmap (\(res, (_data, logs)) -> (res, logs))- $ flip runReaderT sock- $ flip runStateT (Nothing, [])- $ runExceptT (greet >> code)+ run sock =+ fmap (\(res, (_data, logs)) -> (res, logs))+ $ (`runReaderT` sock)+ $ (`runStateT` (Nothing, []))+ $ runExceptT (greet >> code)
src/System/Nix/Store/Remote/Types.hs view
@@ -2,8 +2,8 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-}-module System.Nix.Store.Remote.Types (- MonadStore+module System.Nix.Store.Remote.Types+ ( MonadStore , StoreConfig(..) , Logger(..) , Field(..)@@ -14,22 +14,27 @@ , getError , setData , clearData- ) where+ )+where -import Data.ByteString (ByteString)-import qualified Data.ByteString.Lazy as BSL-import Network.Socket (Socket)+import Data.ByteString ( ByteString )+import qualified Data.ByteString.Lazy as BSL+import Network.Socket ( Socket ) import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State -data StoreConfig = StoreConfig {- storeDir :: FilePath- , storeSocket :: Socket+data StoreConfig = StoreConfig+ { storeDir :: FilePath+ , storeSocket :: Socket } -type MonadStore a = ExceptT String (StateT (Maybe BSL.ByteString, [Logger]) (ReaderT StoreConfig IO)) a+type MonadStore a+ = ExceptT+ String+ (StateT (Maybe BSL.ByteString, [Logger]) (ReaderT StoreConfig IO))+ a type ActivityID = Int type ActivityParentID = Int
src/System/Nix/Store/Remote/Util.hs view
@@ -8,17 +8,19 @@ import Data.Either import Data.Binary.Get import Data.Binary.Put-import Data.Text (Text)-import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TL+import Data.Text ( Text )+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL import Data.Time import Data.Time.Clock.POSIX-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as BSC-import qualified Data.ByteString.Lazy as BSL+import Data.ByteString ( ByteString )+import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Lazy as BSL -import Network.Socket.ByteString (recv, sendAll)+import Network.Socket.ByteString ( recv+ , sendAll+ ) import Nix.Derivation @@ -32,23 +34,21 @@ genericIncremental :: (MonadIO m) => m (Maybe ByteString) -> Get a -> m a genericIncremental getsome parser = go decoder- where- decoder = runGetIncremental parser- go (Done _leftover _consumed x) = do- return x- go (Partial k) = do- chunk <- getsome- go (k chunk)- go (Fail _leftover _consumed msg) = do- error msg+ 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 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+ where+ sockGet8 :: MonadStore (Maybe BSC.ByteString)+ sockGet8 = do+ soc <- asks storeSocket+ liftIO $ Just <$> recv soc 8 sockPut :: Put -> MonadStore () sockPut p = do@@ -72,19 +72,22 @@ sockGetPath :: MonadStore StorePath sockGetPath = do- sd <- getStoreDir+ sd <- getStoreDir pth <- getSocketIncremental (getPath sd)- case pth of- Left e -> throwError e- Right x -> return x+ either+ throwError+ pure+ pth sockGetPathMay :: MonadStore (Maybe StorePath) sockGetPathMay = do- sd <- getStoreDir+ sd <- getStoreDir pth <- getSocketIncremental (getPath sd)- return $ case pth of- Left _e -> Nothing- Right x -> Just x+ pure $+ either+ (const Nothing)+ Just+ pth sockGetPaths :: MonadStore StorePathSet sockGetPaths = do@@ -107,26 +110,28 @@ putText = putByteStringLen . textToBSL putTexts :: [Text] -> Put-putTexts = putByteStrings . map textToBSL+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 . map (parsePath sd) <$> getByteStrings+getPaths sd =+ Data.HashSet.fromList . rights . fmap (parsePath sd) <$> getByteStrings putPath :: StorePath -> Put-putPath = putByteStringLen . BSL.fromStrict . storePathToRawFilePath+putPath = putByteStringLen . BSL.fromStrict . storePathToRawFilePath putPaths :: StorePathSet -> Put-putPaths = putByteStrings . Data.HashSet.toList . Data.HashSet.map (BSL.fromStrict . storePathToRawFilePath)+putPaths = putByteStrings . Data.HashSet.toList . Data.HashSet.map+ (BSL.fromStrict . storePathToRawFilePath) putBool :: Bool -> Put putBool True = putInt (1 :: Int) putBool False = putInt (0 :: Int) getBool :: Get Bool-getBool = (==1) <$> (getInt :: Get Int)+getBool = (== 1) <$> (getInt :: Get Int) putEnum :: (Enum a) => a -> Put putEnum = putInt . fromEnum@@ -141,22 +146,23 @@ getTime = posixSecondsToUTCTime <$> getEnum getBuildResult :: Get BuildResult-getBuildResult = BuildResult- <$> getEnum- <*> (Just . bsToText <$> getByteStringLen)- <*> getInt- <*> getBool- <*> getTime- <*> getTime+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+ putText outputName+ putPath path+ putText hashAlgo+ putText hash putMany putPath inputSrcs putText platform
tests/Derivation.hs view
@@ -4,14 +4,21 @@ module Derivation where -import Control.Monad.IO.Class (liftIO)+import Control.Monad.IO.Class ( liftIO ) -import Data.Text (Text)-import Nix.Derivation (Derivation(..), DerivationOutput(..))-import System.Nix.StorePath (StorePath, storePathToText)+import Data.Text ( Text )+import Nix.Derivation ( Derivation(..)+ , DerivationOutput(..)+ )+import System.Nix.StorePath ( StorePath+ , storePathToText+ ) -import System.Nix.Store.Remote (MonadStore, addToStore, addTextToStore)-import System.Nix.Hash (HashAlgorithm(SHA256))+import System.Nix.Store.Remote ( MonadStore+ , addToStore+ , addTextToStore+ )+import System.Nix.Hash ( HashAlgorithm(SHA256) ) import qualified Data.Map import qualified Data.Set@@ -24,13 +31,13 @@ import qualified System.Directory drvSample :: StorePath -> StorePath -> StorePath -> Derivation StorePath Text-drvSample builder' buildScript out = Derivation {- outputs = Data.Map.fromList [ ("out", DerivationOutput out "sha256" "test") ]- , inputDrvs = Data.Map.fromList [ (builder', Data.Set.fromList [ "out" ]) ]- , inputSrcs = Data.Set.fromList [ buildScript ]+drvSample builder' buildScript out = Derivation+ { outputs = Data.Map.fromList [("out", DerivationOutput out "sha256" "test")]+ , inputDrvs = Data.Map.fromList [(builder', Data.Set.fromList ["out"])]+ , inputSrcs = Data.Set.fromList [buildScript] , platform = "x86_64-linux" , builder = storePathToText builder'- , args = Data.Vector.fromList ["-e", storePathToText buildScript ]+ , args = Data.Vector.fromList ["-e", storePathToText buildScript] , env = Data.Map.fromList [("testEnv", "true")] } @@ -41,34 +48,35 @@ Nothing -> error "No bash executable found" Just fp -> do let Right n = System.Nix.StorePath.makeStorePathName "bash"- pth <- addToStore @'SHA256 n fp False (pure True) False+ pth <- addToStore @ 'SHA256 n fp False (pure True) False action pth withBuildScript :: (StorePath -> MonadStore a) -> MonadStore a withBuildScript action = do- pth <- addTextToStore- "buildScript"- (Data.Text.concat [ "declare -xp", "export > $out" ])- mempty- False+ pth <- addTextToStore "buildScript"+ (Data.Text.concat ["declare -xp", "export > $out"])+ mempty+ False action pth -withDerivation :: (StorePath -> Derivation StorePath Text -> MonadStore a) -> MonadStore a-withDerivation action = withBuildScript $ \buildScript -> withBash $ \bash -> do- outputPath <- addTextToStore "wannabe-output" "" mempty False+withDerivation+ :: (StorePath -> Derivation StorePath Text -> MonadStore a) -> MonadStore a+withDerivation action = withBuildScript $ \buildScript -> withBash $ \bash ->+ do+ outputPath <- addTextToStore "wannabe-output" "" mempty False - let d = drvSample bash buildScript outputPath+ let d = drvSample bash buildScript outputPath - pth <- addTextToStore- "hnix-store-derivation"- (Data.Text.Lazy.toStrict+ pth <- addTextToStore+ "hnix-store-derivation"+ ( Data.Text.Lazy.toStrict $ Data.Text.Lazy.Builder.toLazyText $ System.Nix.Derivation.buildDerivation d- )- mempty- False+ )+ mempty+ False - liftIO $ print d- action pth d+ liftIO $ print d+ action pth d
tests/Driver.hs view
@@ -1,4 +1,4 @@-import NixDaemon+import NixDaemon import qualified Spec -- we run remote tests in
tests/NixDaemon.hs view
@@ -5,23 +5,28 @@ module NixDaemon where -import Control.Monad (void)-import Control.Monad.IO.Class (liftIO)-import Control.Exception (bracket)-import Control.Concurrent (threadDelay)-import Data.Either (isRight, isLeft)-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.HashSet as HS-import qualified Data.Map.Strict as M+import Data.Bool ( bool )+import Control.Monad ( void )+import Control.Monad.IO.Class ( liftIO )+import Control.Exception ( bracket )+import Control.Concurrent ( threadDelay )+import Data.Either ( isRight+ , isLeft+ )+import Data.Text ( Text )+import qualified Data.HashSet as HS+import qualified Data.Map.Strict as M import System.Directory import qualified System.Environment import System.IO.Temp-import qualified System.Process as P-import System.Posix.User as U-import System.Linux.Namespaces as NS-import Test.Tasty.Hspec (Spec, describe, context)-import qualified Test.Tasty.Hspec as Hspec+import qualified System.Process as P+import System.Posix.User as U+import System.Linux.Namespaces as NS+import Test.Tasty.Hspec ( Spec+ , describe+ , context+ )+import qualified Test.Tasty.Hspec as Hspec import Test.Hspec.Expectations.Lifted import System.FilePath@@ -34,39 +39,40 @@ import Derivation -createProcessEnv :: FilePath- -> String- -> [String]- -> IO P.ProcessHandle+createProcessEnv :: FilePath -> String -> [String] -> IO P.ProcessHandle createProcessEnv fp proc args = do- mPath <- System.Environment.lookupEnv "PATH"+ mPath <- System.Environment.lookupEnv "PATH" - (_, _, _, ph) <- P.createProcess (P.proc proc args) { P.cwd = Just $ fp- , P.env = Just $ mockedEnv mPath fp }- return ph+ (_, _, _, 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 = map (\(a, b) -> (a, b)) [- ("NIX_STORE_DIR", fp </> "store")+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")+ , ("NIX_LOG_DIR" , fp </> "var" </> "log")+ , ("NIX_STATE_DIR" , fp </> "var" </> "nix")+ , ("NIX_CONF_DIR" , fp </> "etc") -- , ("NIX_REMOTE", "daemon")- ] ++ (maybe [] (\x -> [("PATH", x)]) mEnvPath)+ ] <> (maybe [] (\x -> [("PATH", x)]) mEnvPath) waitSocket :: FilePath -> Int -> IO () waitSocket _ 0 = fail "No socket" waitSocket fp x = do ex <- doesFileExist fp- case ex of- True -> return ()- False -> threadDelay 100000 >> waitSocket fp (x - 1)+ bool+ (threadDelay 100000 >> waitSocket fp (x - 1))+ (pure ())+ ex writeConf :: FilePath -> IO ()-writeConf fp = do- writeFile fp $ unlines [- "build-users-group = "+writeConf fp =+ writeFile fp $ unlines+ [ "build-users-group = " , "trusted-users = root" , "allowed-users = *" , "fsync-metadata = false"@@ -85,14 +91,16 @@ 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+ :: 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- return (p, runStoreOpts sockFp (fp </> "store"))- where- sockFp = fp </> "var/nix/daemon-socket/socket"+ pure (p, runStoreOpts sockFp (fp </> "store"))+ where+ sockFp = fp </> "var/nix/daemon-socket/socket" enterNamespaces :: IO () enterNamespaces = do@@ -100,21 +108,20 @@ gid <- getEffectiveGroupID unshare [User, Network, Mount]- -- map our (parent) uid to root+ -- fmap our (parent) uid to root writeUserMappings Nothing [UserMapping 0 uid 1]- -- map our (parent) gid to root group+ -- 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 = do+withNixDaemon action = withSystemTempDirectory "test-nix-store" $ \path -> do mapM_ (createDirectory . snd)- (filter ((/= "NIX_REMOTE") . fst) $ mockedEnv Nothing path)+ (filter ((/= "NIX_REMOTE") . fst) $ mockedEnv Nothing path) - ini <- createProcessEnv path- "nix-store" ["--init"]+ ini <- createProcessEnv path "nix-store" ["--init"] void $ P.waitForProcess ini writeFile (path </> "dummy") "Hello World"@@ -134,7 +141,8 @@ -> m c -> (a -> Bool) -> Hspec.SpecWith (m () -> IO (a, b))-it name action check = Hspec.it name $ \run -> (run (action >> return ())) `checks` check+it name action check =+ Hspec.it name $ \run -> (run (action >> pure ())) `checks` check itRights :: (Show a, Show b, Show c, Monad m)@@ -160,7 +168,7 @@ dummy = do let Right n = makeStorePathName "dummy" res <- addToStore @'SHA256 n "dummy" False (pure True) False- return res+ pure res invalidPath :: StorePath invalidPath =@@ -173,29 +181,29 @@ action path builderSh :: Text-builderSh = T.concat [ "declare -xp", "export > $out" ]+builderSh = "declare -xpexport > $out" spec_protocol :: Spec-spec_protocol = Hspec.around withNixDaemon $ do+spec_protocol = Hspec.around withNixDaemon $ describe "store" $ do - context "syncWithGC" $ do+ context "syncWithGC" $ itRights "syncs with garbage collector" syncWithGC context "verifyStore" $ do- itRights "check=False repair=False" $ do+ itRights "check=False repair=False" $ verifyStore False False `shouldReturn` False - itRights "check=True repair=False" $ do+ itRights "check=True repair=False" $ verifyStore True False `shouldReturn` False --privileged- itRights "check=True repair=True" $ do+ itRights "check=True repair=True" $ verifyStore True True `shouldReturn` False - context "addTextToStore" $ do- itRights "adds text to store" $ withPath $ const return ()+ context "addTextToStore" $+ itRights "adds text to store" $ withPath $ const pure () context "isValidPathUncached" $ do itRights "validates path" $ withPath $ \path -> do@@ -205,18 +213,19 @@ context "queryAllValidPaths" $ do itRights "empty query" $ queryAllValidPaths- itRights "non-empty query" $ withPath $ \path -> queryAllValidPaths `shouldReturn` (HS.fromList [path])+ itRights "non-empty query" $ withPath $ \path ->+ queryAllValidPaths `shouldReturn` (HS.fromList [path]) - context "queryPathInfoUncached" $ do+ context "queryPathInfoUncached" $ itRights "queries path info" $ withPath $ queryPathInfoUncached - context "ensurePath" $ do+ context "ensurePath" $ itRights "simple ensure" $ withPath $ ensurePath - context "addTempRoot" $ do+ context "addTempRoot" $ itRights "simple addition" $ withPath $ addTempRoot - context "addIndirectRoot" $ do+ context "addIndirectRoot" $ itRights "simple addition" $ withPath $ addIndirectRoot context "buildPaths" $ do@@ -232,27 +241,25 @@ let pathSet = HS.fromList [path] buildPaths pathSet Repair - context "roots" $ do- context "findRoots" $ do+ 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)+ roots `shouldSatisfy` ((== 1) . M.size) - context "optimiseStore" $ do- itRights "optimises" $ optimiseStore+ context "optimiseStore" $ itRights "optimises" $ optimiseStore - context "queryMissing" $ do+ 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" $ do+ context "addToStore" $ itRights "adds file to store" $ do fp <- liftIO $ writeSystemTempFile "addition" "lal" let Right n = makeStorePathName "tmp-addition"- res <- addToStore @'SHA256 n fp False (pure True) False+ res <- addToStore @ 'SHA256 n fp False (pure True) False liftIO $ print res context "with dummy" $ do@@ -263,8 +270,8 @@ liftIO $ putStrLn $ show path (isValidPathUncached path) `shouldReturn` True - context "derivation" $ do- itRights "build derivation" $ do+ context "derivation" $+ itRights "build derivation" $ withDerivation $ \path drv -> do result <- buildDerivation path drv Normal- result `shouldSatisfy` ((==AlreadyValid) . status)+ result `shouldSatisfy` ((== AlreadyValid) . status)
tests/Util.hs view
@@ -6,9 +6,7 @@ import Test.Tasty.QuickCheck prop_TextToBSLRoundtrip :: Text -> Property-prop_TextToBSLRoundtrip x =- bslToText (textToBSL x) === x+prop_TextToBSLRoundtrip x = bslToText (textToBSL x) === x prop_TextToBSRoundtrip :: Text -> Property-prop_TextToBSRoundtrip x =- bsToText (textToBS x) === x+prop_TextToBSRoundtrip x = bsToText (textToBS x) === x