hnix-store-remote 0.1.0.0 → 0.3.0.0
raw patch · 17 files changed
+1037/−391 lines, 17 filesdep +attoparsecdep +directorydep +filepathdep −pretty-simpledep ~hnix-store-corenew-uploader
Dependencies added: attoparsec, directory, filepath, hspec-expectations-lifted, linux-namespaces, nix-derivation, process, quickcheck-text, tasty, tasty-discover, tasty-hspec, tasty-hunit, tasty-quickcheck, temporary, time, vector, which
Dependencies removed: pretty-simple
Dependency ranges changed: hnix-store-core
Files
- ChangeLog.md +14/−0
- README.md +3/−2
- app/Main.hs +0/−79
- hnix-store-remote.cabal +59/−16
- src/System/Nix/Store/Remote.hs +223/−195
- src/System/Nix/Store/Remote/Binary.hs +55/−0
- src/System/Nix/Store/Remote/Builders.hs +42/−0
- src/System/Nix/Store/Remote/Logger.hs +19/−3
- src/System/Nix/Store/Remote/Parsers.hs +55/−0
- src/System/Nix/Store/Remote/Protocol.hs +48/−26
- src/System/Nix/Store/Remote/Types.hs +36/−12
- src/System/Nix/Store/Remote/Util.hs +124/−58
- tests/Derivation.hs +72/−0
- tests/Driver.hs +9/−0
- tests/NixDaemon.hs +264/−0
- tests/Spec.hs +1/−0
- tests/Util.hs +13/−0
+ ChangeLog.md view
@@ -0,0 +1,14 @@+# Revision history for hnix-store-remote++## 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.
README.md view
@@ -12,6 +12,7 @@ ```haskell +import Control.Monad.IO.Class (liftIO) import Data.HashSet as HS import System.Nix.Store.Remote @@ -21,6 +22,6 @@ roots <- findRoots liftIO $ print roots - res <- addTextToStore "hnix-store" "test" (HS.fromList []) False- print res+ res <- addTextToStore "hnix-store" "test" (HS.fromList []) False+ liftIO $ print res ```
− app/Main.hs
@@ -1,79 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DataKinds #-}-import qualified Data.ByteString.Lazy as LBS-import qualified Data.HashSet as HS-import Data.Maybe-import Control.Monad.Reader-import Text.Pretty.Simple-import Data.Proxy--import qualified System.Nix.GC as GC-import System.Nix.Path (PathHashAlgo)-import System.Nix.Store.Remote-import System.Nix.Store.Remote.Util-import System.Nix.Hash--noSuchPath = fromJust $ mkPath "blah"--main = do- x <- runStore $ do- syncWithGC-- verifyStore False False-- (Just path) <- addTextToStore "hnix-store" "test" (HS.fromList []) False-- -- (Just path2) <- addTextToStore "hnix-store2" "test2" (HS.fromList []) False- path2 <- addToStore "hi-test-file"- "/home/greghale/code/hnix-store/hnix-store-remote/hi"- False (Proxy :: Proxy 'SHA256) (const True) False-- valid <- isValidPathUncached path- valid2 <- isValidPathUncached path2-- case (valid, valid2) of- (True, True) -> do- info <- queryPathInfoUncached path- info2 <- queryPathInfoUncached path2- return (path, info, path2, info2)- _ -> error "shouldn't happen"-- pPrint x- case x of- (Left err, log) -> putStrLn err >> print log- (Right (path, pathinfo, path2, pathinfo2), log) -> do- gcres <- runStore $ do- collectGarbage $ GC.Options- { GC.operation = GC.DeleteSpecific- , GC.pathsToDelete = HS.fromList [path]- , GC.ignoreLiveness = False- -- XXX: this breaks stuff - we don't get Last,- -- only a message with limit reached, stopping..- --- -- gcDeleteSpecific and options.maxFreed- -- are two distinct branches in- -- nix/src/libstore.gc- -- so maybe this combination is not supported- --, GC.maxFreed = 1000- , GC.maxFreed = -1- }-- pPrint gcres-- -- test ExceptT- e <- runStore $ do- isValidPathUncached $ noSuchPath-- pPrint e-- {-- e <- runStore $ do- queryPathInfoUncached $ noSuchPath-- pPrint e- -}-- --res <- queryDerivationOutputs drvP- --liftIO $ print res- --res <- findRoots- --liftIO $ pPrint res
hnix-store-remote.cabal view
@@ -1,5 +1,5 @@ name: hnix-store-remote-version: 0.1.0.0+version: 0.3.0.0 synopsis: Remote hnix store description: Implementation of the nix store using the daemon protocol. homepage: https://github.com/haskell-nix/hnix-store@@ -8,45 +8,88 @@ author: Richard Marko maintainer: srk@48.io copyright: 2018 Richard Marko-category: System+category: Nix build-type: Simple-extra-source-files: README.md+extra-source-files: ChangeLog.md, README.md cabal-version: >=1.10 +flag io-testsuite+ default:+ False+ description:+ Enable testsuite, which requires external+ binaries and Linux namespace support.+ library exposed-modules: System.Nix.Store.Remote+ , System.Nix.Store.Remote.Binary+ , System.Nix.Store.Remote.Builders , System.Nix.Store.Remote.Logger+ , System.Nix.Store.Remote.Parsers , System.Nix.Store.Remote.Protocol , System.Nix.Store.Remote.Types , System.Nix.Store.Remote.Util build-depends: base >=4.10 && <5- , base64-bytestring+ , attoparsec , bytestring , binary , bytestring , containers+ , filepath , text , unix , network+ , nix-derivation >= 1.1.1 && <2 , mtl , unordered-containers--- , pretty-simple--- , base16-bytestring--- , base32-bytestring+ , filepath+ , time , hnix-store-core+ , vector hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall -executable hnix-store-temporary-live-test- main-is: Main.hs- hs-source-dirs: app- build-depends: base- , mtl- , bytestring- , hnix-store-core+test-suite hnix-store-remote-tests+ if !flag(io-testsuite)+ buildable: False++ ghc-options: -rtsopts -fprof-auto+ type: exitcode-stdio-1.0+ main-is: Driver.hs+ other-modules: Derivation+ , NixDaemon+ , Spec+ , Util+ hs-source-dirs: tests+ build-depends:+ attoparsec+ , hnix-store-core >= 0.3 , hnix-store-remote+ , base+ , base64-bytestring+ , binary+ , bytestring+ , containers+ , directory+ , process+ , filepath+ , hspec-expectations-lifted+ , quickcheck-text+ , tasty+ , tasty-discover+ , tasty-hspec+ , tasty-hunit+ , tasty-quickcheck+ , linux-namespaces+ , mtl+ , nix-derivation+ , temporary+ , text+ , time+ , unix , unordered-containers- , pretty-simple- default-language: Haskell2010+ , vector+ , which+ default-language: Haskell2010
src/System/Nix/Store/Remote.hs view
@@ -4,280 +4,308 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-}-module System.Nix.Store.Remote (- runStore+{-# LANGUAGE RecordWildCards #-}+module System.Nix.Store.Remote+ (+ addToStore+ , addTextToStore+ , addSignatures+ , addIndirectRoot+ , addTempRoot+ , buildPaths+ , buildDerivation+ , ensurePath+ , findRoots , isValidPathUncached , queryValidPaths , queryAllValidPaths , querySubstitutablePaths- , querySubstitutablePathInfos , queryPathInfoUncached , queryReferrers , queryValidDerivers , queryDerivationOutputs , queryDerivationOutputNames , queryPathFromHashPart- , addToStoreNar- , addToStore- , addTextToStore- , buildPaths- , buildDerivation- , ensurePath- , addTempRoot- , addIndirectRoot- , syncWithGC- , findRoots- , collectGarbage+ , queryMissing , optimiseStore+ , runStore+ , syncWithGC , verifyStore- , addSignatures- , queryMissing- ) where+ )+ where -import Control.Monad-import Control.Monad.IO.Class (liftIO)-import qualified Data.Binary as B-import qualified Data.Binary.Put as B-import Data.Maybe-import qualified Data.ByteString.Lazy as LBS-import qualified Data.Map.Strict as M-import Data.Proxy (Proxy(Proxy))-import qualified Data.Text.Lazy as T-import qualified Data.Text.Lazy.Encoding as T+import Control.Monad (void, unless, when)+import Data.ByteString.Lazy (ByteString)+import Data.Map.Strict (Map)+import Data.Text (Text) -import qualified System.Nix.Build as Build-import qualified System.Nix.Derivation as Drv-import qualified System.Nix.GC as GC-import System.Nix.Hash (Digest, HashAlgorithm)-import System.Nix.Path-import System.Nix.Hash-import System.Nix.Nar (localPackNar, putNar, narEffectsIO)-import System.Nix.Util+import Nix.Derivation (Derivation)+import System.Nix.Build (BuildMode, BuildResult)+import System.Nix.Hash (Digest, NamedAlgo, ValidAlgo, SomeNamedDigest(..))+import System.Nix.StorePath (StorePath, StorePathName, StorePathSet, StorePathHashAlgo)+import System.Nix.StorePathMetadata (StorePathMetadata(..), StorePathTrust(..)) +import qualified Control.Monad.IO.Class+import qualified Data.Binary.Put+import qualified Data.ByteString.Lazy+import qualified Data.Map.Strict+import qualified Data.Set+import qualified Data.Text.Encoding+import qualified Data.Text.Lazy++import qualified System.Nix.Nar+import qualified System.Nix.Hash+import qualified System.Nix.StorePath+import qualified System.Nix.Store.Remote.Builders+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 --- tmp-import qualified Data.ByteString.Base64.Lazy as B64- type RepairFlag = Bool type CheckFlag = Bool type CheckSigsFlag = Bool type SubstituteFlag = Bool ---setOptions :: StoreSetting -> MonadStore ()+-- | 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 name pth recursive _pathFilter _repair = do -isValidPathUncached :: Path -> MonadStore Bool-isValidPathUncached p = simpleOpArgs IsValidPath $ putPath p+ runOpArgsIO AddToStore $ \yield -> do+ yield $ Data.ByteString.Lazy.toStrict $ Data.Binary.Put.runPut $ do+ putText $ System.Nix.StorePath.unStorePathName name -queryValidPaths :: PathSet -> SubstituteFlag -> MonadStore PathSet+ putBool+ $ not+ $ System.Nix.Hash.algoName @a == "sha256" && recursive++ putBool recursive++ putText $ System.Nix.Hash.algoName @a++ System.Nix.Nar.streamNarIO yield System.Nix.Nar.narEffectsIO pth++ 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+ -> [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+ putInt 0++ res <- getSocketIncremental $ getBuildResult+ return res++ensurePath :: StorePath -> MonadStore ()+ensurePath pn = do+ void $ simpleOpArgs EnsurePath $ putPath pn++-- | Find garbage collector roots.+findRoots :: MonadStore (Map ByteString StorePath)+findRoots = do+ runOp FindRoots+ sd <- getStoreDir+ res <- getSocketIncremental+ $ getMany+ $ (,) <$> (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++ 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++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 PathSet+queryAllValidPaths :: MonadStore StorePathSet queryAllValidPaths = do runOp QueryAllValidPaths sockGetPaths -querySubstitutablePaths :: PathSet -> MonadStore PathSet+querySubstitutablePaths :: StorePathSet -> MonadStore StorePathSet querySubstitutablePaths ps = do runOpArgs QuerySubstitutablePaths $ do putPaths ps sockGetPaths -querySubstitutablePathInfos :: PathSet -> MonadStore [SubstitutablePathInfo]-querySubstitutablePathInfos ps = do- runOpArgs QuerySubstitutablePathInfos $ do- putPaths ps-- cnt <- sockGetInt- forM (take cnt $ cycle [(0 :: Int)]) $ pure $ do- _pth <- sockGetPath- drv <- sockGetStr- refs <- sockGetPaths- dlSize <- sockGetInt- narSize' <- sockGetInt- return $ SubstitutablePathInfo {- deriver = mkPath drv- , references = refs- , downloadSize = dlSize- , narSize = narSize'- }--queryPathInfoUncached :: Path -> MonadStore ValidPathInfo-queryPathInfoUncached p = do+queryPathInfoUncached :: StorePath+ -> MonadStore StorePathMetadata+queryPathInfoUncached path = do runOpArgs QueryPathInfo $ do- putPath p+ putPath path valid <- sockGetBool unless valid $ error "Path is not valid" - drv <- sockGetStr- hash' <- lBSToText <$> sockGetStr- refs <- sockGetPaths- regTime <- sockGetInt- size <- sockGetInt- ulti <- sockGetBool- sigs' <- map lBSToText <$> sockGetStrings- ca' <- lBSToText <$> sockGetStr- return $ ValidPathInfo {- path = p- , deriverVP = mkPath drv- , narHash = hash'- , referencesVP = refs- , registrationTime = regTime- , narSizeVP = size- , ultimate = ulti- , sigs = sigs'- , ca = ca'- }+ deriverPath <- sockGetPathMay -queryReferrers :: Path -> MonadStore PathSet+ narHashText <- Data.Text.Encoding.decodeUtf8 <$> sockGetStr+ let narHash = case System.Nix.Hash.decodeBase32 @'System.Nix.Hash.SHA256 narHashText of+ Left e -> error e+ Right x -> SomeDigest x++ references <- sockGetPaths+ registrationTime <- sockGet getTime+ narBytes <- Just <$> sockGetInt+ ultimate <- sockGetBool++ _sigStrings <- map 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+ Right x -> Just x++ trust = if ultimate then BuiltLocally+ else BuiltElsewhere++ return $ StorePathMetadata {..}++queryReferrers :: StorePath -> MonadStore StorePathSet queryReferrers p = do runOpArgs QueryReferrers $ do putPath p sockGetPaths -queryValidDerivers :: Path -> MonadStore PathSet+queryValidDerivers :: StorePath -> MonadStore StorePathSet queryValidDerivers p = do runOpArgs QueryValidDerivers $ do putPath p sockGetPaths -queryDerivationOutputs :: Path -> MonadStore PathSet+queryDerivationOutputs :: StorePath -> MonadStore StorePathSet queryDerivationOutputs p = do runOpArgs QueryDerivationOutputs $ putPath p sockGetPaths -queryDerivationOutputNames :: Path -> MonadStore PathSet+queryDerivationOutputNames :: StorePath -> MonadStore StorePathSet queryDerivationOutputNames p = do runOpArgs QueryDerivationOutputNames $ putPath p sockGetPaths --- XXX: this is broken as I don't know how to get hashes from paths (fix mkPath)-queryPathFromHashPart :: Digest PathHashAlgo -> MonadStore (Maybe Path)-queryPathFromHashPart d = do+queryPathFromHashPart :: Digest StorePathHashAlgo -> MonadStore StorePath+queryPathFromHashPart storePathHash = do runOpArgs QueryPathFromHashPart $- -- TODO: replace `undefined` with digest encoding function when- -- [issue 24](https://github.com/haskell-nix/hnix-store/issues/24) is- -- closed- putByteStringLen $ LBS.fromStrict $ undefined d- sockGetPath--type Source = () -- abstract binary source-addToStoreNar :: ValidPathInfo -> Source -> RepairFlag -> CheckSigsFlag -> MonadStore ()-addToStoreNar = undefined -- XXX--type PathFilter = Path -> Bool--addToStore- :: forall a. (ValidAlgo a, NamedAlgo a)- => LBS.ByteString- -> FilePath- -> Bool- -> Proxy a- -> PathFilter- -> RepairFlag- -> MonadStore Path-addToStore name pth recursive algoProxy pfilter repair = do-- -- TODO: Is this lazy enough? We need `B.putLazyByteString bs` to stream `bs`- bs :: LBS.ByteString <- liftIO $ B.runPut . putNar <$> localPackNar narEffectsIO pth-- runOpArgs AddToStore $ do- putByteStringLen name- putInt 1- if recursive- then putInt 1- else putInt 0-- putByteStringLen (T.encodeUtf8 . T.toLower . T.fromStrict $ algoName @a)-- B.putLazyByteString bs-- fmap (fromMaybe $ error "TODO: Error") sockGetPath---addTextToStore :: LBS.ByteString -> LBS.ByteString -> PathSet -> RepairFlag -> MonadStore (Maybe Path)-addTextToStore name text references' repair = do- runOpArgs AddTextToStore $ do- putByteStringLen name- putByteStringLen text- putPaths references'+ putByteStringLen+ $ Data.ByteString.Lazy.fromStrict+ $ Data.Text.Encoding.encodeUtf8+ $ System.Nix.Hash.encodeBase32 storePathHash sockGetPath -buildPaths :: PathSet -> Build.BuildMode -> MonadStore ()-buildPaths ps bm = void $ simpleOpArgs EnsurePath $ do- putPaths ps- putInt $ fromEnum bm--buildDerivation :: PathName -> Drv.Derivation -> Build.BuildMode -> MonadStore Build.BuildResult-buildDerivation = undefined -- XXX--ensurePath :: Path -> MonadStore ()-ensurePath pn = void $ simpleOpArgs EnsurePath $ putPath pn+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 -addTempRoot :: Path -> MonadStore ()-addTempRoot pn = void $ simpleOpArgs AddTempRoot $ putPath pn+ willBuild <- sockGetPaths+ willSubstitute <- sockGetPaths+ unknown <- sockGetPaths+ downloadSize' <- sockGetInt+ narSize' <- sockGetInt+ return (willBuild, willSubstitute, unknown, downloadSize', narSize') -addIndirectRoot :: Path -> MonadStore ()-addIndirectRoot pn = void $ simpleOpArgs AddIndirectRoot $ putPath pn+optimiseStore :: MonadStore ()+optimiseStore = void $ simpleOp OptimiseStore syncWithGC :: MonadStore () syncWithGC = void $ simpleOp SyncWithGC -findRoots :: MonadStore Roots-findRoots = do- runOp FindRoots- res <- getSocketIncremental (do- count <- getInt- res <- sequence $ replicate count ((,) <$> getPath <*> getPath)- return res- )-- return $ M.fromList $ catMaybesTupled res- where- catMaybesTupled :: [(Maybe a, Maybe b)] -> [(a, b)]- catMaybesTupled ls = map (\(Just x, Just y) -> (x, y)) $ filter (\(x,y) -> isJust x && isJust y) ls--collectGarbage :: GC.Options -> MonadStore GC.Result-collectGarbage opts = do- runOpArgs CollectGarbage $ do- putInt $ fromEnum $ GC.operation opts- putPaths $ GC.pathsToDelete opts- putBool $ GC.ignoreLiveness opts- putInt $ GC.maxFreed opts- forM_ [(0 :: Int)..2] $ pure $ putInt (0 :: Int) -- removed options-- paths <- sockGetPaths- freed <- sockGetInt- _obsolete <- sockGetInt :: MonadStore Int-- return $ GC.Result paths freed--optimiseStore :: MonadStore ()-optimiseStore = void $ simpleOp OptimiseStore- -- returns True on errors verifyStore :: CheckFlag -> RepairFlag -> MonadStore Bool verifyStore check repair = simpleOpArgs VerifyStore $ do putBool check putBool repair--addSignatures :: Path -> [LBS.ByteString] -> MonadStore ()-addSignatures p signatures = void $ simpleOpArgs AddSignatures $ do- putPath p- putByteStrings signatures---- TODO:-queryMissing :: PathSet -> MonadStore (PathSet, PathSet, PathSet, Integer, Integer)-queryMissing ps = undefined -- willBuild willSubstitute unknown downloadSize narSize--
+ src/System/Nix/Store/Remote/Binary.hs view
@@ -0,0 +1,55 @@+{-|+Description : Utilities for packing stuff+Maintainer : srk <srk@48.io>+|-}+module System.Nix.Store.Remote.Binary where++import Control.Monad+import Data.Binary.Get+import Data.Binary.Put+import Data.ByteString (ByteString)+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 = sequence_ $ replicate 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)+ return $ BSL.toStrict st+ where unpad x = sequence $ replicate x getWord8++getByteStrings :: Get [ByteString]+getByteStrings = getMany getByteStringLen
+ src/System/Nix/Store/Remote/Builders.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}++module System.Nix.Store.Remote.Builders (+ buildContentAddressableAddress+ ) where++import Data.Text.Lazy (Text)+import System.Nix.Hash (Digest, SomeNamedDigest(SomeDigest))+import System.Nix.StorePath (ContentAddressableAddress(..))++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 =+ Data.Text.Lazy.Builder.toLazyText . contentAddressableAddressBuilder++contentAddressableAddressBuilder+ :: ContentAddressableAddress+ -> Builder+contentAddressableAddressBuilder (Text digest) =+ "text:"+ <> digestBuilder digest+contentAddressableAddressBuilder (Fixed _narHashMode (SomeDigest (digest :: Digest hashAlgo))) =+ "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.encodeBase32
src/System/Nix/Store/Remote/Logger.hs view
@@ -1,16 +1,20 @@+{-# LANGUAGE RankNTypes #-} module System.Nix.Store.Remote.Logger ( Logger(..) , Field(..) , processOutput) where -import Control.Monad.Reader (ask, liftIO)+import Control.Monad.Except+import Control.Monad.Reader (ask)+import Control.Monad.State (get) import Data.Binary.Get import Network.Socket.ByteString (recv) +import System.Nix.Store.Remote.Binary import System.Nix.Store.Remote.Types-import System.Nix.Util+import System.Nix.Store.Remote.Util controlParser :: Get Logger controlParser = do@@ -34,12 +38,24 @@ 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++ next <- go decoder+ return $ next+ -- we should probably handle Read here as well x -> do next <- go decoder return $ x:next go (Partial k) = do- soc <- ask+ soc <- storeSocket <$> ask chunk <- liftIO (Just <$> recv soc 8) go (k chunk)
+ src/System/Nix/Store/Remote/Parsers.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}++module System.Nix.Store.Remote.Parsers+ ( parseContentAddressableAddress+ )+where++import Control.Applicative ( (<|>) )+import Data.Attoparsec.ByteString.Char8+import Data.ByteString.Char8+import qualified Data.Text+import Data.Text.Encoding ( decodeUtf8 )+import System.Nix.Hash+import System.Nix.StorePath ( ContentAddressableAddress(..)+ , NarHashMode(..)+ )++-- | 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:<h>@+caText :: Parser ContentAddressableAddress+caText = do+ _ <- "text:sha256:"+ digest <- decodeBase32 @'SHA256 <$> parseHash+ either fail return $ Text <$> digest++-- | Parser for @fixed:<r?>:<ht>:<h>@+caFixed :: Parser ContentAddressableAddress+caFixed = do+ _ <- "fixed:"+ narHashMode <- (pure Recursive <$> "r:") <|> (pure RegularFile <$> "")+ digest <- parseTypedDigest+ either fail return $ Fixed narHashMode <$> digest++parseTypedDigest :: Parser (Either String SomeNamedDigest)+parseTypedDigest = mkNamedDigest <$> parseHashType <*> parseHash++parseHashType :: Parser Data.Text.Text+parseHashType = decodeUtf8 <$> ("sha256" <|> "sha512" <|> "sha1" <|> "md5") <* (":" <|> "-")++parseHash :: Parser Data.Text.Text+parseHash = decodeUtf8 <$> takeWhile1 (/= ':')
src/System/Nix/Store/Remote/Protocol.hs view
@@ -1,10 +1,15 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} module System.Nix.Store.Remote.Protocol ( WorkerOp(..) , simpleOp , simpleOpArgs , runOp , runOpArgs- , runStore) where+ , runOpArgsIO+ , runStore+ , runStoreOpts) where import Control.Exception (bracket) import Control.Monad.Except@@ -13,16 +18,18 @@ import Data.Binary.Get import Data.Binary.Put-import qualified Data.ByteString.Char8 as BSC-import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString+import qualified Data.ByteString.Char8+import qualified Data.ByteString.Lazy -import Network.Socket hiding (send, sendTo, recv, recvFrom)-import Network.Socket.ByteString (recv)+import Network.Socket (SockAddr(SockAddrUnix))+import qualified Network.Socket+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-import System.Nix.Util protoVersion :: Int protoVersion = 0x115@@ -34,8 +41,8 @@ workerMagic2 :: Int workerMagic2 = 0x6478696f -sockPath :: String-sockPath = "/nix/var/nix/daemon-socket/socket"+defaultSockPath :: String+defaultSockPath = "/nix/var/nix/daemon-socket/socket" data WorkerOp = IsValidPath@@ -118,7 +125,7 @@ case err of True -> do Error _num msg <- head <$> getError- throwError $ BSC.unpack $ LBS.toStrict msg+ throwError $ Data.ByteString.Char8.unpack msg False -> do sockGetBool @@ -126,38 +133,50 @@ runOp op = runOpArgs op $ return () runOpArgs :: WorkerOp -> Put -> MonadStore ()-runOpArgs op args = do+runOpArgs op args = runOpArgsIO op (\encode -> encode $ Data.ByteString.Lazy.toStrict $ runPut args) - -- Temporary hack for printing the messages destined for nix-daemon socket- when False $- liftIO $ LBS.writeFile "mytestfile2" $ runPut $ do- putInt $ opNum op- args+runOpArgsIO :: WorkerOp -> ((Data.ByteString.ByteString -> MonadStore ()) -> MonadStore ()) -> MonadStore ()+runOpArgsIO op encoder = do sockPut $ do putInt $ opNum op- args + soc <- storeSocket <$> ask+ encoder (liftIO . sendAll soc)+ out <- processOutput- modify (++out)+ modify (\(a, b) -> (a, b++out)) err <- gotError when err $ do Error _num msg <- head <$> getError- throwError $ BSC.unpack $ LBS.toStrict msg+ throwError $ Data.ByteString.Char8.unpack msg runStore :: MonadStore a -> IO (Either String a, [Logger])-runStore code = do- bracket (open sockPath) close run+runStore = runStoreOpts defaultSockPath "/nix/store"++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 <- socket AF_UNIX Stream 0- connect soc (SockAddrUnix path)- return soc+ soc <-+ Network.Socket.socket+ Network.Socket.AF_UNIX+ Network.Socket.Stream+ 0++ Network.Socket.connect soc (SockAddrUnix path)+ return $ StoreConfig { storeSocket = soc+ , storeDir = storeRootDir }+ greet = do sockPut $ putInt workerMagic1- soc <- ask+ soc <- storeSocket <$> ask vermagic <- liftIO $ recv soc 16- let (magic2, daemonProtoVersion) = flip runGet (LBS.fromStrict vermagic) $ (,) <$> getInt <*> getInt+ 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@@ -167,4 +186,7 @@ processOutput run sock =- flip runReaderT sock $ flip runStateT [] $ runExceptT (greet >> code)+ fmap (\(res, (_data, logs)) -> (res, logs))+ $ flip runReaderT sock+ $ flip runStateT (Nothing, [])+ $ runExceptT (greet >> code)
src/System/Nix/Store/Remote/Types.hs view
@@ -1,37 +1,52 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-} module System.Nix.Store.Remote.Types ( MonadStore+ , StoreConfig(..) , Logger(..) , Field(..)+ , getStoreDir , getLog , flushLog , gotError- , getError) where+ , getError+ , setData+ , clearData+ ) where -import qualified Data.ByteString.Lazy as LBS+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 -type MonadStore a = ExceptT String (StateT [Logger] (ReaderT Socket IO)) a+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 LBS.ByteString | LogInt Int+data Field = LogStr ByteString | LogInt Int deriving (Eq, Ord, Show) data Logger =- Next LBS.ByteString+ Next ByteString | Read Int -- data needed from source- | Write LBS.ByteString -- data for sink+ | Write ByteString -- data for sink | Last- | Error Int LBS.ByteString- | StartActivity ActivityID Verbosity ActivityType LBS.ByteString [Field] ActivityParentID+ | Error Int ByteString+ | StartActivity ActivityID Verbosity ActivityType ByteString [Field] ActivityParentID | StopActivity ActivityID | Result ActivityID ResultType [Field] deriving (Eq, Ord, Show)@@ -41,13 +56,22 @@ isError _ = False gotError :: MonadStore Bool-gotError = any isError <$> get+gotError = any isError . snd <$> get getError :: MonadStore [Logger]-getError = filter isError <$> get+getError = filter isError . snd <$> get getLog :: MonadStore [Logger]-getLog = get+getLog = snd <$> get flushLog :: MonadStore ()-flushLog = put []+flushLog = modify (\(a, _b) -> (a, []))++setData :: BSL.ByteString -> MonadStore ()+setData x = modify (\(_, b) -> (Just x, b))++clearData :: MonadStore ()+clearData = modify (\(_, b) -> (Nothing, b))++getStoreDir :: MonadStore FilePath+getStoreDir = storeDir <$> ask
src/System/Nix/Store/Remote/Util.hs view
@@ -1,54 +1,64 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE RecordWildCards #-} module System.Nix.Store.Remote.Util where +import Control.Monad.Except import Control.Monad.Reader -import Data.Maybe+import Data.Either import Data.Binary.Get import Data.Binary.Put import Data.Text (Text) import qualified Data.Text as T-import qualified Data.ByteString as B+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 LBS-import qualified Data.HashSet as HashSet+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 System.Nix.Hash-import System.Nix.Path-import System.Nix.Util +import qualified Data.HashSet+import qualified Data.Map -genericIncremental :: (MonadIO m) => m (Maybe B.ByteString) -> Get a -> m a+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) = do+ return x+ go (Partial k) = do+ chunk <- getsome+ go (k chunk)+ go (Fail _leftover _consumed msg) = do+ error msg getSocketIncremental :: Get a -> MonadStore a-getSocketIncremental = genericIncremental sockGet+getSocketIncremental = genericIncremental sockGet8+ where+ sockGet8 :: MonadStore (Maybe BSC.ByteString)+ sockGet8 = do+ soc <- storeSocket <$> ask+ liftIO $ Just <$> recv soc 8 sockPut :: Put -> MonadStore () sockPut p = do- soc <- ask- liftIO $ sendAll soc $ LBS.toStrict $ runPut p--sockGet :: MonadStore (Maybe BSC.ByteString)-sockGet = do- soc <- ask- liftIO $ Just <$> recv soc 8--sockGetPath :: MonadStore (Maybe Path)-sockGetPath = getSocketIncremental getPath+ soc <- storeSocket <$> ask+ liftIO $ sendAll soc $ BSL.toStrict $ runPut p -sockGetPaths :: MonadStore PathSet-sockGetPaths = getSocketIncremental getPaths+sockGet :: Get a -> MonadStore a+sockGet = getSocketIncremental sockGetInt :: Integral a => MonadStore a sockGetInt = getSocketIncremental getInt@@ -56,48 +66,104 @@ sockGetBool :: MonadStore Bool sockGetBool = (== (1 :: Int)) <$> sockGetInt -sockGetStr :: MonadStore LBS.ByteString+sockGetStr :: MonadStore ByteString sockGetStr = getSocketIncremental getByteStringLen -sockGetStrings :: MonadStore [LBS.ByteString]+sockGetStrings :: MonadStore [ByteString] sockGetStrings = getSocketIncremental getByteStrings -lBSToText :: LBS.ByteString -> Text-lBSToText = T.pack . BSC.unpack . LBS.toStrict+sockGetPath :: MonadStore StorePath+sockGetPath = do+ sd <- getStoreDir+ pth <- getSocketIncremental (getPath sd)+ case pth of+ Left e -> throwError e+ Right x -> return x -textToLBS :: Text -> LBS.ByteString-textToLBS = LBS.fromStrict . BSC.pack . T.unpack+sockGetPathMay :: MonadStore (Maybe StorePath)+sockGetPathMay = do+ sd <- getStoreDir+ pth <- getSocketIncremental (getPath sd)+ return $ case pth of+ Left _e -> Nothing+ Right x -> Just x --- XXX: needs work-mkPath :: LBS.ByteString -> Maybe Path-mkPath p = case (pathName $ lBSToText p) of- -- TODO: replace `undefined` with digest encoding function when- -- [issue 24](https://github.com/haskell-nix/hnix-store/issues/24)- -- is closed- Just x -> Just $ Path (hash $ LBS.toStrict p) x --XXX: hash- Nothing -> Nothing+sockGetPaths :: MonadStore StorePathSet+sockGetPaths = do+ sd <- getStoreDir+ getSocketIncremental (getPaths sd) --- WOOT--- import Data.ByteString.Base32 as Base32---drvP = Path (fromJust $ digestFromByteString $ pls $ Base32.decode $ BSC.take 32 $ BSC.drop (BSC.length "/nix/store/") drv) (fromJust $ pathName $ T.pack $ BSC.unpack drv)---pls (Left _) = error "unable to decode hash"---pls (Right x) = x+bsToText :: ByteString -> Text+bsToText = T.decodeUtf8 -getPath :: Get (Maybe Path)-getPath = mkPath <$> getByteStringLen+textToBS :: Text -> ByteString+textToBS = T.encodeUtf8 -getPaths :: Get PathSet-getPaths = HashSet.fromList . catMaybes . map mkPath <$> getByteStrings+bslToText :: BSL.ByteString -> Text+bslToText = TL.toStrict . TL.decodeUtf8 -putPathName :: PathName -> Put-putPathName = putByteStringLen . textToLBS . pathNameContents+textToBSL :: Text -> BSL.ByteString+textToBSL = TL.encodeUtf8 . TL.fromStrict -putPath :: Path -> Put-putPath (Path _hash name) = putPathName name+putText :: Text -> Put+putText = putByteStringLen . textToBSL -putPaths :: PathSet -> Put-putPaths = putByteStrings . HashSet.map (\(Path _hash name) -> textToLBS $ pathNameContents name)+putTexts :: [Text] -> Put+putTexts = putByteStrings . (map 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++putPath :: StorePath -> Put+putPath = putByteStringLen . BSL.fromStrict . storePathToRawFilePath++putPaths :: StorePathSet -> Put+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)++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)+ $ \(first, second) -> putText first >> putText second
+ tests/Derivation.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}++module Derivation where++import Control.Monad.IO.Class (liftIO)++import Data.Text (Text)+import Nix.Derivation (Derivation(..), DerivationOutput(..))+import System.Nix.StorePath (StorePath, storePathToText)++import System.Nix.Store.Remote (addToStore, addTextToStore)+import System.Nix.Hash (HashAlgorithm(Truncated, SHA256))++import qualified Data.Map+import qualified Data.Set+import qualified Data.Text+import qualified Data.Text.Lazy+import qualified Data.Text.Lazy.Builder+import qualified Data.Vector+import qualified Nix.Derivation+import qualified System.Nix.Derivation+import qualified System.Nix.StorePath+import qualified System.Which++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 ]+ , platform = "x86_64-linux"+ , builder = storePathToText builder+ , args = Data.Vector.fromList ["-e", storePathToText buildScript ]+ , env = Data.Map.fromList [("testEnv", "true")]+ }++withBash action = do+ mfp <- liftIO $ System.Which.which "bash"+ case mfp of+ Nothing -> error "No bash executable found"+ Just fp -> do+ let Right n = System.Nix.StorePath.makeStorePathName "bash"+ path <- addToStore @SHA256 n fp False (pure True) False+ action path++withBuildScript action = do+ path <- addTextToStore+ "buildScript"+ (Data.Text.concat [ "declare -xp", "export > $out" ])+ mempty+ False++ action path++withDerivation action = withBuildScript $ \buildScript -> withBash $ \bash -> do+ outputPath <- addTextToStore "wannabe-output" "" mempty False++ let d = drvSample bash buildScript outputPath++ path <- addTextToStore+ "hnix-store-derivation"+ (Data.Text.Lazy.toStrict+ $ Data.Text.Lazy.Builder.toLazyText+ $ System.Nix.Derivation.buildDerivation d+ )+ mempty+ False++ liftIO $ print d+ action path d+
+ tests/Driver.hs view
@@ -0,0 +1,9 @@+import Test.Tasty.Hspec+import NixDaemon+import qualified Spec++-- we run remote tests in+-- Linux namespaces to avoid interacting with systems store+main = do+ enterNamespaces+ Spec.main
+ tests/NixDaemon.hs view
@@ -0,0 +1,264 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module NixDaemon where++import Prelude+import Control.Monad+import Control.Monad.IO.Class (liftIO, MonadIO)+import Control.Exception (bracket)+import Control.Concurrent (threadDelay)+import Data.Either (isRight, isLeft, fromRight)+import Data.Binary.Put+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64.Lazy as B64+import qualified Data.ByteString.Lazy as BSL+import Data.Monoid ((<>))+import Data.Maybe (fromJust)+import Data.Proxy+import Data.Time+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder+import qualified Data.HashSet as HS+import qualified Data.Map.Strict as M+import qualified Data.Set as S+import qualified Data.Vector as V+import System.Directory+import qualified System.Environment+import System.IO.Temp+import qualified System.IO as IO (hGetContents, hPutStr, openFile)+import qualified System.Process as P+import System.Posix.User as U+import System.Linux.Namespaces as NS+import Test.Tasty as T+import Test.Tasty.Hspec (Spec, HasCallStack, describe, context)+import qualified Test.Tasty.Hspec as Hspec+import Test.Hspec.Expectations.Lifted+import qualified Test.Tasty.HUnit as HU+import Test.Tasty.QuickCheck+import Text.Read (readMaybe)++import System.FilePath++import System.Nix.Build+import System.Nix.Hash+import System.Nix.StorePath+import System.Nix.ReadonlyStore+import System.Nix.Nar+import qualified System.Nix.StorePathMetadata as VP+import System.Nix.Store.Remote+import System.Nix.Store.Remote.Logger+import System.Nix.Store.Remote.Types+import System.Nix.Store.Remote.Protocol+import System.Nix.Store.Remote.Util++import Derivation++createProcessEnv :: FilePath+ -> String+ -> [String]+ -> IO P.ProcessHandle+createProcessEnv fp proc args = do+ mPath <- System.Environment.lookupEnv "PATH"++ (_, _, _, ph) <- P.createProcess (P.proc proc args) { P.cwd = Just $ fp+ , P.env = Just $ mockedEnv mPath fp }+ return ph++mockedEnv :: Maybe String -> FilePath -> [(String, FilePath)]+mockedEnv mEnvPath fp = map (\(a, b) -> (a, b)) [+ ("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_REMOTE", "daemon")+ ] ++ (maybe [] (\x -> [("PATH", x)]) mEnvPath)++waitSocket :: FilePath -> Int -> IO ()+waitSocket fp 0 = fail "No socket"+waitSocket fp x = do+ ex <- doesFileExist fp+ case ex of+ True -> return ()+ False -> threadDelay 100000 >> waitSocket fp (x - 1)++writeConf fp = do+ 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 -> 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"++enterNamespaces = do+ uid <- getEffectiveUserID+ gid <- getEffectiveGroupID++ unshare [User, Network, Mount]+ -- map our (parent) uid to root+ writeUserMappings Nothing [UserMapping 0 uid 1]+ -- map our (parent) gid to root group+ writeGroupMappings Nothing [GroupMapping 0 gid 1] True++withNixDaemon action = do+ withSystemTempDirectory "test-nix-store" $ \path -> do++ mapM_ (createDirectory . snd)+ (filter ((/= "NIX_REMOTE") . fst) $ mockedEnv Nothing path)++ ini <- createProcessEnv path+ "nix-store" ["--init"]+ P.waitForProcess ini++ writeFile (path </> "dummy") "Hello World"++ setCurrentDirectory path++ bracket (startDaemon path)+ (P.terminateProcess . fst)+ (\x -> action . snd $ x)++checks action check = action >>= (`Hspec.shouldSatisfy` (check . fst))+it name action check = Hspec.it name $ \run -> (run (action >> return ())) `checks` check+itRights name action = it name action isRight+itLefts name action = it name action isLeft++withPath action = do+ path <- addTextToStore "hnix-store" "test" (HS.fromList []) False+ action path++-- | dummy path, adds <tmp>/dummpy with "Hello World" contents+dummy = do+ let Right n = makeStorePathName "dummy"+ res <- addToStore @SHA256 n "dummy" False (pure True) False+ return res++invalidPath :: StorePath+invalidPath =+ let Right n = makeStorePathName "invalid"+ in StorePath (hash "invalid") n "no_such_root"++withBuilder action = do+ path <- addTextToStore "builder" builderSh (HS.fromList []) False+ action path++builderSh = T.concat [ "declare -xp", "export > $out" ]++spec_protocol :: Spec+spec_protocol = Hspec.around withNixDaemon $ do++ describe "store" $ do++ context "syncWithGC" $ do+ itRights "syncs with garbage collector" syncWithGC++ context "verifyStore" $ do+ itRights "check=False repair=False" $ do+ verifyStore False False `shouldReturn` False++ itRights "check=True repair=False" $ do+ verifyStore True False `shouldReturn` False++ --privileged+ itRights "check=True repair=True" $ do+ verifyStore True True `shouldReturn` False++ context "addTextToStore" $ do+ itRights "adds text to store" $ withPath $ const return ()++ context "isValidPathUncached" $ do+ itRights "validates path" $ withPath $ \path -> do+ liftIO $ putStrLn $ show 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" $ do+ itRights "queries path info" $ withPath $ queryPathInfoUncached++ context "ensurePath" $ do+ itRights "simple ensure" $ withPath $ ensurePath++ context "addTempRoot" $ do+ itRights "simple addition" $ withPath $ addTempRoot++ context "addIndirectRoot" $ do+ 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" $ do+ context "findRoots" $ do+ itRights "empty roots" $ (findRoots `shouldReturn` M.empty)++ itRights "path added as a temp root" $ withPath $ \path -> do+ roots <- findRoots+ roots `shouldSatisfy` ((==1) . M.size)++ context "optimiseStore" $ do+ itRights "optimises" $ optimiseStore++ context "queryMissing" $ do+ itRights "queries" $ withPath $ \path -> do+ let pathSet = HS.fromList [path]+ queryMissing pathSet `shouldReturn` (HS.empty, HS.empty, HS.empty, 0, 0)++ context "addToStore" $ do+ 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+ liftIO $ print res++ context "with dummy" $ do+ itRights "adds dummy" dummy++ itRights "valid dummy" $ do+ path <- dummy+ liftIO $ putStrLn $ show path+ (isValidPathUncached path) `shouldReturn` True++ context "derivation" $ do+ itRights "build derivation" $ do+ withDerivation $ \path drv -> do+ result <- buildDerivation path drv Normal+ result `shouldSatisfy` ((==AlreadyValid) . status)
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --generated-module=Spec #-}
+ tests/Util.hs view
@@ -0,0 +1,13 @@++module Util where++import Test.Tasty.QuickCheck+import Data.Text.Arbitrary++import System.Nix.Store.Remote.Util++prop_TextToBSLRoundtrip x =+ bslToText (textToBSL x) === x++prop_TextToBSRoundtrip x =+ bsToText (textToBS x) === x