diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 ``` diff --git a/app/Main.hs b/app/Main.hs deleted file mode 100644 --- a/app/Main.hs +++ /dev/null @@ -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 diff --git a/hnix-store-remote.cabal b/hnix-store-remote.cabal --- a/hnix-store-remote.cabal +++ b/hnix-store-remote.cabal @@ -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 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 @@ -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 - - diff --git a/src/System/Nix/Store/Remote/Binary.hs b/src/System/Nix/Store/Remote/Binary.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Binary.hs @@ -0,0 +1,55 @@ +{-| +Description : Utilities for packing stuff +Maintainer : srk +|-} +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 diff --git a/src/System/Nix/Store/Remote/Builders.hs b/src/System/Nix/Store/Remote/Builders.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Builders.hs @@ -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 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,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) diff --git a/src/System/Nix/Store/Remote/Parsers.hs b/src/System/Nix/Store/Remote/Parsers.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Parsers.hs @@ -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:@ +caText :: Parser ContentAddressableAddress +caText = do + _ <- "text:sha256:" + digest <- decodeBase32 @'SHA256 <$> parseHash + either fail return $ Text <$> digest + +-- | Parser for @fixed:::@ +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 (/= ':') diff --git a/src/System/Nix/Store/Remote/Protocol.hs b/src/System/Nix/Store/Remote/Protocol.hs --- a/src/System/Nix/Store/Remote/Protocol.hs +++ b/src/System/Nix/Store/Remote/Protocol.hs @@ -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) 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,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 diff --git a/src/System/Nix/Store/Remote/Util.hs b/src/System/Nix/Store/Remote/Util.hs --- a/src/System/Nix/Store/Remote/Util.hs +++ b/src/System/Nix/Store/Remote/Util.hs @@ -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 diff --git a/tests/Derivation.hs b/tests/Derivation.hs new file mode 100644 --- /dev/null +++ b/tests/Derivation.hs @@ -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 + diff --git a/tests/Driver.hs b/tests/Driver.hs new file mode 100644 --- /dev/null +++ b/tests/Driver.hs @@ -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 diff --git a/tests/NixDaemon.hs b/tests/NixDaemon.hs new file mode 100644 --- /dev/null +++ b/tests/NixDaemon.hs @@ -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 /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) diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --generated-module=Spec #-} diff --git a/tests/Util.hs b/tests/Util.hs new file mode 100644 --- /dev/null +++ b/tests/Util.hs @@ -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