diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,29 @@ # Revision history for hnix-store-core -## 0.1.0.0 -- YYYY-mm-dd +## (unreleased) 0.3.0.0 -- 2020-XY-ZV + +* `System.Nix.Nar` changes API to support NAR format streaming: + * `buildNarIO :: FilePath -> Handle -> IO ()` - Create a NAR from a regular filesystem object, stream it out on the Handle + * `unpackNarIO :: Handle -> FilePath -> IO ()` - Recreate filesystem object from a NAR file accessed by the Handle +* `StorePath` type changed to simple variant without type level +symbolic store path root. +* Added `makeFixedOutputPath` to `System.Nix.ReadonlyStore` +* Added `decodeBase16` and `decodeBase32` to `System.Nix.Hash` +* `System.Nix.StorePath` module now provides + * `storePathToFilePath` and `storePathToText` helpers + * `storePathToNarInfo` for converting paths to `narinfo` URLs + * `parsePath` function + * `pathParser` Attoparsec parser +* Added `System.Nix.Build` module +* Added `System.Nix.Derivation` module +* Removed `System.Nix.Util` module, moved to `hnix-store-remote` +* Added base64 and SHA512 hash support + +## 0.2.0.0 -- 2020-03-12 + +Removed `System.Nix.Store`. We may reintroduce it later when multiple backends +exist and we can tell what common effects they should share. + +## 0.1.0.0 -- 2019-03-18 * First version. diff --git a/hnix-store-core.cabal b/hnix-store-core.cabal --- a/hnix-store-core.cabal +++ b/hnix-store-core.cabal @@ -1,5 +1,5 @@ name: hnix-store-core -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Core effects for interacting with the Nix store. description: This package contains types and functions needed to describe @@ -11,15 +11,21 @@ author: Shea Levy maintainer: shea@shealevy.com copyright: 2018 Shea Levy -category: System +category: Nix build-type: Simple extra-source-files: ChangeLog.md, README.md cabal-version: >=1.10 library exposed-modules: System.Nix.Base32 + , System.Nix.Build + , System.Nix.Derivation , System.Nix.Hash + , System.Nix.Internal.Base32 , System.Nix.Internal.Hash + , System.Nix.Internal.Nar.Parser + , System.Nix.Internal.Nar.Streamer + , System.Nix.Internal.Nar.Effects , System.Nix.Internal.Signature , System.Nix.Internal.StorePath , System.Nix.Nar @@ -27,22 +33,27 @@ , System.Nix.Signature , System.Nix.StorePath , System.Nix.StorePathMetadata - , System.Nix.Util build-depends: base >=4.10 && <5 + , attoparsec + , algebraic-graphs >= 0.5 && < 0.6 , base16-bytestring + , base64-bytestring , bytestring , binary , bytestring + , cereal , containers , cryptohash-md5 , cryptohash-sha1 , cryptohash-sha256 + , cryptohash-sha512 , directory , filepath , hashable + , lifted-base + , monad-control , mtl - , regex-base - , regex-tdfa >= 1.3.1.0 + , nix-derivation >= 1.1.1 && <2 , saltine , time , text @@ -63,24 +74,35 @@ type: exitcode-stdio-1.0 main-is: Driver.hs other-modules: + Arbitrary + Derivation NarFormat Hash + StorePath hs-source-dirs: tests build-depends: hnix-store-core + , attoparsec , base + , base16-bytestring , base64-bytestring , binary , bytestring , containers + , filepath , directory + , filepath + , io-streams , process + , process-extras , tasty , tasty-discover + , tasty-golden , tasty-hspec , tasty-hunit , tasty-quickcheck , temporary , text + , unix default-language: Haskell2010 diff --git a/src/System/Nix/Base32.hs b/src/System/Nix/Base32.hs --- a/src/System/Nix/Base32.hs +++ b/src/System/Nix/Base32.hs @@ -1,39 +1,9 @@ {-| Description: Implementation of Nix's base32 encoding. -} -module System.Nix.Base32 where - -import qualified Data.ByteString as BS -import qualified Data.Text as T -import qualified Data.Vector as V - --- | Encode a 'BS.ByteString' in Nix's base32 encoding -encode :: BS.ByteString -> T.Text -encode c = T.pack $ map char32 [nChar - 1, nChar - 2 .. 0] - where - digits32 = V.fromList "0123456789abcdfghijklmnpqrsvwxyz" - -- Each base32 character gives us 5 bits of information, while - -- each byte gives is 8. Because 'div' rounds down, we need to add - -- one extra character to the result, and because of that extra 1 - -- we need to subtract one from the number of bits in the - -- bytestring to cover for the case where the number of bits is - -- already a factor of 5. Thus, the + 1 outside of the 'div' and - -- the - 1 inside of it. - nChar = fromIntegral $ ((BS.length c * 8 - 1) `div` 5) + 1 - - byte = BS.index c . fromIntegral - - -- May need to switch to a more efficient calculation at some - -- point. - bAsInteger :: Integer - bAsInteger = sum [fromIntegral (byte j) * (256 ^ j) - | j <- [0 .. BS.length c - 1] - ] +module System.Nix.Base32 ( + encode + , decode + ) where - char32 :: Integer -> Char - char32 i = digits32 V.! digitInd - where - digitInd = fromIntegral $ - bAsInteger - `div` (32^i) - `mod` 32 +import System.Nix.Internal.Base32 diff --git a/src/System/Nix/Build.hs b/src/System/Nix/Build.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Build.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE RecordWildCards #-} +{-| +Description : Build related types +Maintainer : srk +|-} +module System.Nix.Build ( + BuildMode(..) + , BuildStatus(..) + , BuildResult(..) + , buildSuccess + ) where + +import Data.Time (UTCTime) +import Data.Text (Text) +import Data.HashSet (HashSet) + +-- keep the order of these Enums to match enums from reference implementations +-- src/libstore/store-api.hh +data BuildMode = Normal | Repair | Check + deriving (Eq, Ord, Enum, Show) + +data BuildStatus = + Built + | Substituted + | AlreadyValid + | PermanentFailure + | InputRejected + | OutputRejected + | TransientFailure -- possibly transient + | CachedFailure -- no longer used + | TimedOut + | MiscFailure + | DependencyFailed + | LogLimitExceeded + | NotDeterministic + deriving (Eq, Ord, Enum, Show) + + +-- | Result of the build +data BuildResult = BuildResult + { -- | build status, MiscFailure should be default + status :: !BuildStatus + , -- | possible build error message + errorMessage :: !(Maybe Text) + , -- | How many times this build was performed + timesBuilt :: !Integer + , -- | If timesBuilt > 1, whether some builds did not produce the same result + isNonDeterministic :: !Bool + , -- Start time of this build + startTime :: !UTCTime + , -- Stop time of this build + stopTime :: !UTCTime + } deriving (Eq, Ord, Show) + +buildSuccess BuildResult{..} = status == Built || status == Substituted || status == AlreadyValid diff --git a/src/System/Nix/Derivation.hs b/src/System/Nix/Derivation.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Derivation.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.Nix.Derivation ( + parseDerivation + , buildDerivation + ) where + +import Data.Attoparsec.Text.Lazy (Parser) +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Text.Lazy.Builder (Builder) +import Nix.Derivation (Derivation) +import System.Nix.StorePath (StorePath, pathParser) + +import qualified Data.ByteString.Char8 +import qualified Data.Text +import qualified Data.Text.Lazy.Builder +import qualified Data.Attoparsec.Text.Lazy + +import qualified Nix.Derivation +import qualified System.Nix.StorePath + +parseDerivation :: FilePath -> Parser (Derivation StorePath Text) +parseDerivation expectedRoot = + Nix.Derivation.parseDerivationWith + ("\"" *> System.Nix.StorePath.pathParser expectedRoot <* "\"") + Nix.Derivation.textParser + +buildDerivation :: Derivation StorePath Text -> Builder +buildDerivation derivation = + Nix.Derivation.buildDerivationWith + (string . Data.Text.pack . show) + string + derivation + where + string = Data.Text.Lazy.Builder.fromText . Data.Text.pack . show diff --git a/src/System/Nix/Hash.hs b/src/System/Nix/Hash.hs --- a/src/System/Nix/Hash.hs +++ b/src/System/Nix/Hash.hs @@ -10,9 +10,12 @@ , HNix.SomeNamedDigest(..) , HNix.hash , HNix.hashLazy + , HNix.mkNamedDigest , HNix.encodeBase32 + , HNix.decodeBase32 , HNix.encodeBase16 + , HNix.decodeBase16 ) where import qualified System.Nix.Internal.Hash as HNix diff --git a/src/System/Nix/Internal/Base32.hs b/src/System/Nix/Internal/Base32.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Internal/Base32.hs @@ -0,0 +1,82 @@ + +module System.Nix.Internal.Base32 where + +import Data.Bits (shiftR) +import Data.Char (chr, ord) +import Data.Word (Word8) +import Data.List (unfoldr) +import Data.Maybe (isJust, catMaybes) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.Text as T +import qualified Data.Vector as V +import Numeric (readInt) + +-- omitted: E O U T +digits32 = V.fromList "0123456789abcdfghijklmnpqrsvwxyz" + +-- | Encode a 'BS.ByteString' in Nix's base32 encoding +encode :: BS.ByteString -> T.Text +encode c = T.pack $ map char32 [nChar - 1, nChar - 2 .. 0] + where + -- Each base32 character gives us 5 bits of information, while + -- each byte gives is 8. Because 'div' rounds down, we need to add + -- one extra character to the result, and because of that extra 1 + -- we need to subtract one from the number of bits in the + -- bytestring to cover for the case where the number of bits is + -- already a factor of 5. Thus, the + 1 outside of the 'div' and + -- the - 1 inside of it. + nChar = fromIntegral $ ((BS.length c * 8 - 1) `div` 5) + 1 + + byte = BS.index c . fromIntegral + + -- May need to switch to a more efficient calculation at some + -- point. + bAsInteger :: Integer + bAsInteger = sum [fromIntegral (byte j) * (256 ^ j) + | j <- [0 .. BS.length c - 1] + ] + + char32 :: Integer -> Char + char32 i = digits32 V.! digitInd + where + digitInd = fromIntegral $ + bAsInteger + `div` (32^i) + `mod` 32 + +-- | Decode Nix's base32 encoded text +decode :: T.Text -> Either String BS.ByteString +decode what = case T.all (flip elem digits32) what of + True -> unsafeDecode what + False -> Left "Invalid base32 string" + +-- | Decode Nix's base32 encoded text +-- Doesn't check if all elements match `digits32` +unsafeDecode :: T.Text -> Either String BS.ByteString +unsafeDecode what = + case readInt 32 + (flip elem digits32) + (\c -> maybe (error "character not in digits32") id $ + V.findIndex (==c) digits32) + (T.unpack what) + of + [(i, _)] -> Right $ padded $ integerToBS i + x -> Left $ "Can't decode: readInt returned " ++ show x + where + padded x | BS.length x < decLen = x `BS.append` + (BSC.pack $ take (decLen - BS.length x) (cycle "\NUL")) + padded x | otherwise = x + + decLen = T.length what * 5 `div` 8 + +-- | Encode an Integer to a bytestring +-- Similar to Data.Base32String (integerToBS) without `reverse` +integerToBS :: Integer -> BS.ByteString +integerToBS 0 = BS.pack [0] +integerToBS i + | i > 0 = BS.pack $ unfoldr f i + | otherwise = error "integerToBS not defined for negative values" + where + f 0 = Nothing + f x = Just (fromInteger x :: Word8, x `shiftR` 8) diff --git a/src/System/Nix/Internal/Hash.hs b/src/System/Nix/Internal/Hash.hs --- a/src/System/Nix/Internal/Hash.hs +++ b/src/System/Nix/Internal/Hash.hs @@ -16,8 +16,10 @@ import qualified Crypto.Hash.MD5 as MD5 import qualified Crypto.Hash.SHA1 as SHA1 import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Crypto.Hash.SHA512 as SHA512 import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Base64 as Base64 import Data.Bits (xor) import qualified Data.ByteString.Lazy as BSL import qualified Data.Hashable as DataHashable @@ -37,6 +39,7 @@ = MD5 | SHA1 | SHA256 + | SHA512 | Truncated Nat HashAlgorithm -- ^ The hash algorithm obtained by truncating the result of the -- input 'HashAlgorithm' to the given number of bytes. See @@ -44,8 +47,11 @@ -- | The result of running a 'HashAlgorithm'. newtype Digest (a :: HashAlgorithm) = - Digest BS.ByteString deriving (Show, Eq, Ord, DataHashable.Hashable) + Digest BS.ByteString deriving (Eq, Ord, DataHashable.Hashable) +instance Show (Digest a) where + show = ("Digest " ++) . show . encodeBase32 + -- | The primitive interface for incremental hashing for a given -- 'HashAlgorithm'. Every 'HashAlgorithm' should have an instance. class ValidAlgo (a :: HashAlgorithm) where @@ -61,21 +67,60 @@ -- | A 'HashAlgorithm' with a canonical name, for serialization -- purposes (e.g. SRI hashes) -class NamedAlgo (a :: HashAlgorithm) where +class ValidAlgo a => NamedAlgo (a :: HashAlgorithm) where algoName :: Text + hashSize :: Int instance NamedAlgo 'MD5 where algoName = "md5" + hashSize = 16 instance NamedAlgo 'SHA1 where algoName = "sha1" + hashSize = 20 instance NamedAlgo 'SHA256 where algoName = "sha256" + hashSize = 32 +instance NamedAlgo 'SHA512 where + algoName = "sha512" + hashSize = 64 + -- | A digest whose 'NamedAlgo' is not known at compile time. data SomeNamedDigest = forall a . NamedAlgo a => SomeDigest (Digest a) +instance Show SomeNamedDigest where + show sd = case sd of + SomeDigest (digest :: Digest hashType) -> T.unpack $ "SomeDigest " <> algoName @hashType <> ":" <> encodeBase32 digest + +mkNamedDigest :: Text -> Text -> Either String SomeNamedDigest +mkNamedDigest name sriHash = + let (sriName, hash) = T.breakOnEnd "-" sriHash in + if sriName == "" || sriName == (name <> "-") + then mkDigest name hash + else Left $ T.unpack $ "Sri hash method " <> sriName <> " does not match the required hash type " <> name + where + mkDigest name hash = case name of + "md5" -> SomeDigest <$> decode @'MD5 hash + "sha1" -> SomeDigest <$> decode @'SHA1 hash + "sha256" -> SomeDigest <$> decode @'SHA256 hash + "sha512" -> SomeDigest <$> decode @'SHA512 hash + _ -> Left $ "Unknown hash name: " ++ T.unpack name + decode :: forall a . (NamedAlgo a, ValidAlgo a) => Text -> Either String (Digest a) + decode hash + | size == base16Len = decodeBase16 hash + | size == base32Len = decodeBase32 hash + | size == base64Len = decodeBase64 hash + | otherwise = Left $ T.unpack sriHash ++ " is not a valid " ++ T.unpack name ++ " hash. Its length (" ++ show size ++ ") does not match any of " ++ show [base16Len, base32Len, base64Len] + where + size = T.length hash + hsize = hashSize @a + base16Len = hsize * 2 + base32Len = ((hsize * 8 - 1) `div` 5) + 1; + base64Len = ((4 * hsize `div` 3) + 3) `div` 4 * 4; + + -- | Hash an entire (strict) 'BS.ByteString' as a single call. -- -- For example: @@ -99,10 +144,30 @@ encodeBase32 :: Digest a -> T.Text encodeBase32 (Digest bs) = Base32.encode bs +-- | Decode a 'Digest' in the special Nix base-32 encoding. +decodeBase32 :: T.Text -> Either String (Digest a) +decodeBase32 t = Digest <$> Base32.decode t + -- | Encode a 'Digest' in hex. encodeBase16 :: Digest a -> T.Text encodeBase16 (Digest bs) = T.decodeUtf8 (Base16.encode bs) +-- | Decode a 'Digest' in hex +decodeBase16 :: T.Text -> Either String (Digest a) +decodeBase16 t = case Base16.decode (T.encodeUtf8 t) of + (x, "") -> Right $ Digest x + _ -> Left $ "Unable to decode base16 string " ++ T.unpack t + +-- | Encode a 'Digest' in hex. +encodeBase64 :: Digest a -> T.Text +encodeBase64 (Digest bs) = T.decodeUtf8 (Base64.encode bs) + +-- | Decode a 'Digest' in hex +decodeBase64 :: T.Text -> Either String (Digest a) +decodeBase64 t = case Base64.decode (T.encodeUtf8 t) of + Right x -> Right $ Digest x + Left e -> Left $ "Unable to decode base64 string " ++ T.unpack t ++ ": " ++ e + -- | Uses "Crypto.Hash.MD5" from cryptohash-md5. instance ValidAlgo 'MD5 where type AlgoCtx 'MD5 = MD5.Ctx @@ -123,6 +188,13 @@ initialize = SHA256.init update = SHA256.update finalize = Digest . SHA256.finalize + +-- | Uses "Crypto.Hash.SHA512" from cryptohash-sha512. +instance ValidAlgo 'SHA512 where + type AlgoCtx 'SHA512 = SHA512.Ctx + initialize = SHA512.init + update = SHA512.update + finalize = Digest . SHA512.finalize -- | Reuses the underlying 'ValidAlgo' instance, but does a -- 'truncateDigest' at the end. diff --git a/src/System/Nix/Internal/Nar/Effects.hs b/src/System/Nix/Internal/Nar/Effects.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Internal/Nar/Effects.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module System.Nix.Internal.Nar.Effects + ( NarEffects(..) + , narEffectsIO + ) where + +import qualified Control.Exception.Lifted as Lifted +import qualified Control.Monad.Fail as MonadFail +import qualified Control.Monad.IO.Class as IO +import Control.Monad.Trans.Control (MonadBaseControl) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import Data.Int (Int64) +import qualified System.Directory as Directory +import qualified System.Directory as Directory +import qualified System.IO as IO +import System.Posix.Files (createSymbolicLink, fileSize, + getFileStatus, isDirectory, + readSymbolicLink) + +data NarEffects (m :: * -> *) = NarEffects { + narReadFile :: FilePath -> m BSL.ByteString + , narWriteFile :: FilePath -> BSL.ByteString -> m () + , narStreamFile :: FilePath -> m (Maybe BS.ByteString) -> m () + , narListDir :: FilePath -> m [FilePath] + , narCreateDir :: FilePath -> m () + , narCreateLink :: FilePath -> FilePath -> m () + , narGetPerms :: FilePath -> m Directory.Permissions + , narSetPerms :: FilePath -> Directory.Permissions -> m () + , narIsDir :: FilePath -> m Bool + , narIsSymLink :: FilePath -> m Bool + , narFileSize :: FilePath -> m Int64 + , narReadLink :: FilePath -> m FilePath + , narDeleteDir :: FilePath -> m () + , narDeleteFile :: FilePath -> m () +} + + +-- | A particular @NarEffects@ that uses regular POSIX for file manipulation +-- You would replace this with your own @NarEffects@ if you wanted a +-- different backend +narEffectsIO + :: (IO.MonadIO m, + MonadFail.MonadFail m, + MonadBaseControl IO m + ) => NarEffects m +narEffectsIO = NarEffects { + narReadFile = IO.liftIO . BSL.readFile + , narWriteFile = \a b -> IO.liftIO $ BSL.writeFile a b + , narStreamFile = streamStringOutIO + , narListDir = IO.liftIO . Directory.listDirectory + , narCreateDir = IO.liftIO . Directory.createDirectory + , narCreateLink = \f t -> IO.liftIO $ createSymbolicLink f t + , narGetPerms = IO.liftIO . Directory.getPermissions + , narSetPerms = \f p -> IO.liftIO $ Directory.setPermissions f p + , narIsDir = \d -> fmap isDirectory $ IO.liftIO (getFileStatus d) + , narIsSymLink = IO.liftIO . Directory.pathIsSymbolicLink + , narFileSize = \n -> fmap (fromIntegral . fileSize) $ IO.liftIO (getFileStatus n) + , narReadLink = IO.liftIO . readSymbolicLink + , narDeleteDir = IO.liftIO . Directory.removeDirectoryRecursive + , narDeleteFile = IO.liftIO . Directory.removeFile + } + + +-- | This default implementation for @narStreamFile@ requires @IO.MonadIO@ +streamStringOutIO + :: forall m + .(IO.MonadIO m, + MonadFail.MonadFail m, + MonadBaseControl IO m + ) => FilePath + -> m (Maybe BS.ByteString) + -> m () +streamStringOutIO f getChunk = + Lifted.bracket + (IO.liftIO (IO.openFile f IO.WriteMode)) (IO.liftIO . IO.hClose) go + `Lifted.catch` + cleanupException + where + go :: IO.Handle -> m () + go handle = do + chunk <- getChunk + case chunk of + Nothing -> return () + Just c -> do + IO.liftIO $ BS.hPut handle c + go handle + cleanupException (e :: Lifted.SomeException) = do + IO.liftIO $ Directory.removeFile f + MonadFail.fail $ + "Failed to stream string to " ++ f ++ ": " ++ show e diff --git a/src/System/Nix/Internal/Nar/Parser.hs b/src/System/Nix/Internal/Nar/Parser.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Internal/Nar/Parser.hs @@ -0,0 +1,468 @@ +-- | A streaming parser for the NAR format + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +module System.Nix.Internal.Nar.Parser where + +import qualified Algebra.Graph as Graph +import qualified Algebra.Graph.ToGraph as Graph +import qualified Control.Concurrent as Concurrent +import qualified Control.Exception.Lifted as ExceptionLifted +import Control.Monad (forM, when) +import qualified Control.Monad.Except as Except +import qualified Control.Monad.Fail as Fail +import qualified Control.Monad.IO.Class as IO +import qualified Control.Monad.Reader as Reader +import qualified Control.Monad.State as State +import qualified Control.Monad.Trans as Trans +import qualified Control.Monad.Trans.Control as Base +import qualified Data.Binary.Put as B +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Either as Either +import Data.Int (Int64) +import qualified Data.IORef as IORef +import qualified Data.List as List +import qualified Data.Map as Map +import Data.Maybe (catMaybes) +import qualified Data.Serialize as S +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import qualified System.Directory as Directory +import System.FilePath as FilePath +import qualified System.IO as IO + +import qualified System.Nix.Internal.Nar.Effects as Nar + + +-- | NarParser is a monad for parsing a Nar file as a byte stream +-- and reconstructing the file system objects inside +-- See the definitions of @NarEffects@ for a description +-- of the actions the parser can take, and @ParserState@ for the +-- internals of the parser +newtype NarParser m a = NarParser + { runNarParser + :: State.StateT ParserState + (Except.ExceptT String (Reader.ReaderT (Nar.NarEffects m) m)) a} + deriving ( Functor, Applicative, Monad, Fail.MonadFail + , Trans.MonadIO, State.MonadState ParserState + , Except.MonadError String + , Reader.MonadReader (Nar.NarEffects m) + ) + +-- | Run a @NarParser@ over a byte stream +-- This is suitable for testing the top-level NAR parser, or any of the +-- smaller utilities parsers, if you have bytes appropriate for them +runParser + :: forall m a.(IO.MonadIO m, Base.MonadBaseControl IO m) + => Nar.NarEffects m + -- ^ Provide the effects set, usually @narEffectsIO@ + -> NarParser m a + -- ^ A parser to run, such as @parseNar@ + -> IO.Handle + -- ^ A handle the stream containg the NAR. It should already be + -- open and in @IO.ReadMode@ + -> FilePath + -- ^ The root file system object to be created by the NAR + -> m (Either String a) +runParser effs (NarParser action) h target = do + unpackResult <- Reader.runReaderT + (Except.runExceptT (State.evalStateT action state0)) effs + `ExceptionLifted.catch` exceptionHandler + when (Either.isLeft unpackResult) cleanup + return unpackResult + + where + state0 :: ParserState + state0 = ParserState + { tokenStack = [] + , handle = h + , directoryStack = [target] + , links = [] + } + exceptionHandler :: ExceptionLifted.SomeException -> m (Either String a) + exceptionHandler e = do + return (Left $ "Exception while unpacking NAR file: " ++ show e) + + cleanup :: m () + cleanup = do + isDir <- Nar.narIsDir effs target + if isDir + then Nar.narDeleteDir effs target + else Nar.narDeleteFile effs target + + +instance Trans.MonadTrans NarParser where + lift act = NarParser $ (Trans.lift . Trans.lift . Trans.lift) act + + +data ParserState = ParserState + { tokenStack :: ![T.Text] + -- ^ The parser can push tokens (words or punctuation) + -- onto this stack. We use this for a very limited backtracking + -- where the Nar format requires it + , directoryStack :: ![String] + -- ^ The parser knows the name of the current FSO it's targeting, + -- and the relative directory path leading there + , handle :: IO.Handle + -- ^ Handle of the input byte stream + , links :: [LinkInfo] + -- ^ Unlike with files and directories, we collect symlinks + -- from the NAR on + } + + +------------------------------------------------------------------------------ +-- * Parsers for NAR components + +-- | Parse a NAR byte string, producing @()@. +-- Parsing a NAR is mostly used for its side-effect: producing +-- the file system objects packed in the NAR. That's why we return @()@ +parseNar :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m () +parseNar = do + expectStr "nix-archive-1" + parens $ parseFSO + createLinks + + +parseFSO :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m () +parseFSO = do + expectStr "type" + matchStr + [("symlink", parseSymlink) + ,("regular", parseFile) + ,("directory", parseDirectory) + ] + + +-- | Parse a symlink from a NAR, storing the link details in the parser state +-- We remember links rather than immediately creating file system objects +-- from them, because we might encounter a link in the NAR before we +-- encountered its target, and in this case, creating the link will fail +-- The final step of creating links is handle by @createLinks@ +parseSymlink :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m () +parseSymlink = do + expectStr "target" + target <- parseStr + (dir,file) <- currentDirectoryAndFile + pushLink $ LinkInfo { linkTarget = (T.unpack target), linkFile = file, linkPWD = dir } + where + currentDirectoryAndFile :: Monad m => NarParser m (FilePath, FilePath) + currentDirectoryAndFile = do + dirStack <- State.gets directoryStack + return $ (List.foldr1 () (List.reverse $ drop 1 dirStack), head dirStack) + + +-- | Internal data type representing symlinks encountered in the NAR +data LinkInfo = LinkInfo + { linkTarget :: String + -- ^ path to the symlink target, relative to the root of the unpacking NAR + , linkFile :: String + -- ^ file name of the link being created + , linkPWD :: String + -- ^ directory in which to create the link (relative to unpacking root) + } deriving (Show) + + +-- | When the NAR includes a file, we read from the NAR handle in chunks and +-- write the target in chunks. This lets us avoid reading the full contents +-- of the encoded file into memory +parseFile :: forall m.(IO.MonadIO m, Fail.MonadFail m) => NarParser m () +parseFile = do + + s <- parseStr + when (s `notElem` ["executable", "contents"]) + (Fail.fail $ "Parser found " ++ show s ++ + " when expecting element from " ++ + show ["executable", "contents"]) + when (s == "executable") $ do + expectStr "" + expectStr "contents" + + fSize <- parseLength + + -- Set up for defining `getChunk` + narHandle <- State.gets handle + bytesLeftVar <- IO.liftIO $ IORef.newIORef fSize + + let + -- getChunk tracks the number of total bytes we still need to get from the + -- file (starting at the file size, and decrementing by the size of the + -- chunk we read) + getChunk :: m (Maybe BS.ByteString) + getChunk = do + bytesLeft <- IO.liftIO $ IORef.readIORef bytesLeftVar + if bytesLeft == 0 + then return Nothing + else do + chunk <- IO.liftIO $ BS.hGetSome narHandle (fromIntegral $ min 10000 bytesLeft) + when (BS.null chunk) (Fail.fail "ZERO BYTES") + IO.liftIO $ IORef.modifyIORef bytesLeftVar (\n -> n - fromIntegral (BS.length chunk)) + + -- This short pause is necessary for letting the garbage collector + -- clean up chunks from previous runs. Without it, heap memory usage can + -- quickly spike + IO.liftIO $ Concurrent.threadDelay 10 + return $ Just chunk + + target <- currentFile + streamFile <- Reader.asks Nar.narStreamFile + Trans.lift (streamFile target getChunk) + + when (s == "executable") $ do + effs :: Nar.NarEffects m <- Reader.ask + Trans.lift $ do + p <- Nar.narGetPerms effs target + Nar.narSetPerms effs target (p { Directory.executable = True }) + + expectRawString (BS.replicate (padLen $ fromIntegral fSize) 0) + + +-- | Parse a NAR encoded directory, being careful not to hold onto file +-- handles for target files longer than needed +parseDirectory :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m () +parseDirectory = do + createDirectory <- Reader.asks Nar.narCreateDir + target <- currentFile + Trans.lift $ createDirectory target + parseEntryOrFinish + + where + + parseEntryOrFinish :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m () + parseEntryOrFinish = do + -- If we reach a ")", we finished the directory's entries, and we have + -- to put ")" back into the stream, because the outer call to @parens@ + -- expects to consume it. + -- Otherwise, parse an entry as a fresh file system object + matchStr + [(")", pushStr ")") + ,("entry", parseEntry ) + ] + + parseEntry :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m () + parseEntry = do + parens $ do + expectStr "name" + fName <- parseStr + pushFileName (T.unpack fName) + expectStr "node" + parens $ parseFSO + popFileName + parseEntryOrFinish + + + +------------------------------------------------------------------------------ +-- * Utility parsers + + +-- | Short strings guiding the NAR parsing are prefixed with their +-- length, then encoded in ASCII, and padded to 8 bytes. @parseStr@ +-- captures this logic +parseStr :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m T.Text +parseStr = do + cachedStr <- popStr + case cachedStr of + Just str -> do + return str + Nothing -> do + len <- parseLength + strBytes <- consume (fromIntegral len) + expectRawString (BS.replicate (fromIntegral $ padLen $ fromIntegral len) 0) + return $ E.decodeUtf8 strBytes + + +-- | Get an Int64 describing the length of the upcoming string, +-- according to NAR's encoding of ints +parseLength :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m Int64 +parseLength = do + eightBytes <- consume 8 + case S.runGet S.getInt64le eightBytes of + Left e -> Fail.fail $ "parseLength failed to decode int64: " ++ e + Right n -> return n + + +-- | Consume a NAR string and assert that it matches an expectation +expectStr :: (IO.MonadIO m, Fail.MonadFail m) => T.Text -> NarParser m () +expectStr expected = do + actual <- parseStr + when (actual /= expected) + (Fail.fail $ "Expected " ++ err expected ++ ", got " ++ err actual ) + where + err t = + if T.length t > 10 + then show (T.take 10 t) + else show t + + +-- | Consume a raw string and assert that it equals some expectation. +-- This is usually used when consuming padding 0's +expectRawString :: (IO.MonadIO m, Fail.MonadFail m) => BS.ByteString -> NarParser m () +expectRawString expected = do + actual <- consume (BS.length expected) + when (actual /= expected) $ + Fail.fail $ "Expected " ++ err expected ++ ", got " ++ err actual + where + err bs = + if BS.length bs > 10 + then show (BS.take 10 bs) ++ "..." + else show bs + + +-- | Consume a NAR string, and dispatch to a parser depending on which string +-- matched +matchStr + :: (IO.MonadIO m, Fail.MonadFail m) + => [(T.Text, NarParser m a)] + -- ^ List of expected possible strings and the parsers they should run + -> NarParser m a +matchStr parsers = do + str <- parseStr + case List.lookup str parsers of + Just p -> p + Nothing -> Fail.fail $ "Expected one of " ++ show (fst <$> parsers) ++ " found " ++ show str + + +-- | Wrap any parser in NAR formatted parentheses +-- (a parenthesis is a NAR string, so it needs length encoding and padding) +parens :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m a -> NarParser m a +parens act = do + expectStr "(" + r <- act + expectStr ")" + return r + + +-- | Sort links in the symlink stack according to their connectivity +-- (Targets must be created before the links that target them) +createLinks :: IO.MonadIO m => NarParser m () +createLinks = do + createLink <- Reader.asks Nar.narCreateLink + allLinks <- State.gets links + sortedLinks <- IO.liftIO $ sortLinksIO allLinks + flip mapM_ sortedLinks $ \li -> do + pwd <- IO.liftIO $ Directory.getCurrentDirectory + IO.liftIO $ Directory.setCurrentDirectory (linkPWD li) + Trans.lift $ createLink (linkTarget li) (linkFile li) + IO.liftIO $ Directory.setCurrentDirectory pwd + + where + + -- Convert every target and link file to a filepath relative + -- to NAR root, then @Graph.topSort@ it, and map from the + -- relative filepaths back to the original @LinkInfo@. + -- Relative paths are needed for sorting, but @LinkInfo@s + -- are needed for creating the link files + sortLinksIO :: [LinkInfo] -> IO [LinkInfo] + sortLinksIO ls = do + linkLocations <- fmap Map.fromList $ + forM ls $ \li-> + (,li) <$> Directory.canonicalizePath (linkFile li) + canonicalLinks <- forM ls $ \l -> do + targetAbsPath <- Directory.canonicalizePath + (linkPWD l linkTarget l) + fileAbsPath <- Directory.canonicalizePath + (linkFile l) + return (fileAbsPath, targetAbsPath) + let linkGraph = Graph.edges canonicalLinks + case Graph.topSort linkGraph of + Left _ -> error "Symlinks form a loop" + Right sortedNodes -> + let + sortedLinks = flip Map.lookup linkLocations <$> sortedNodes + in + return $ catMaybes sortedLinks + + +------------------------------------------------------------------------------ +-- * State manipulation + +-- | Pull n bytes from the underlying handle, failing if fewer bytes +-- are available +consume + :: (IO.MonadIO m, Fail.MonadFail m) + => Int + -> NarParser m BS.ByteString +consume 0 = return "" +consume n = do + state0 <- State.get + newBytes <- IO.liftIO $ BS.hGetSome (handle state0) (max 0 n) + when (BS.length newBytes < n) $ + Fail.fail $ + "consume: Not enough bytes in handle. Wanted " + ++ show n ++ " got " ++ show (BS.length newBytes) + return newBytes + + +-- | Pop a string off the token stack +popStr :: Monad m => NarParser m (Maybe T.Text) +popStr = do + s <- State.get + case List.uncons (tokenStack s) of + Nothing -> return Nothing + Just (x,xs) -> do + State.put $ s { tokenStack = xs } + return $ Just x + + +-- | Push a string onto the token stack +pushStr :: Monad m => T.Text -> NarParser m () +pushStr str = do + State.modify $ \s -> -- s { loadedBytes = strBytes <> loadedBytes s } + s { tokenStack = str : tokenStack s } + + +-- | Push a level onto the directory stack +pushFileName :: Monad m => FilePath -> NarParser m () +pushFileName fName = State.modify (\s -> s { directoryStack = fName : directoryStack s }) + + +-- | Go to the parent level in the directory stack +popFileName :: Monad m => NarParser m () +popFileName = do + State.modify (\s -> s { directoryStack = List.drop 1 (directoryStack s )}) + + +-- | Convert the current directory stack into a filepath by interspersing +-- the path components with "/" +currentFile :: Monad m => NarParser m FilePath +currentFile = do + dirStack <- State.gets directoryStack + return $ List.foldr1 () (List.reverse dirStack) + + +-- | Add a link to the collection of encountered symlinks +pushLink :: Monad m => LinkInfo -> NarParser m () +pushLink linkInfo = State.modify (\s -> s { links = linkInfo : links s }) + + +------------------------------------------------------------------------------ +-- * Utilities + +testParser :: (m ~ IO) => NarParser m a -> BS.ByteString -> m (Either String a) +testParser p b = do + BS.writeFile "tmp" b + IO.withFile "tmp" IO.ReadMode $ \h -> + runParser Nar.narEffectsIO p h "tmp" + +testParser' :: (m ~ IO) => FilePath -> IO (Either String ()) +testParser' fp = IO.withFile fp IO.ReadMode $ \h -> runParser Nar.narEffectsIO parseNar h "tmp" + + + + +-- | Distance to the next multiple of 8 +padLen:: Int -> Int +padLen n = (8 - n) `mod` 8 + + +dbgState :: IO.MonadIO m => NarParser m () +dbgState = do + s <- State.get + IO.liftIO $ print (tokenStack s, directoryStack s) diff --git a/src/System/Nix/Internal/Nar/Streamer.hs b/src/System/Nix/Internal/Nar/Streamer.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Internal/Nar/Streamer.hs @@ -0,0 +1,104 @@ +-- | Stream out a NAR file from a regular file + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module System.Nix.Internal.Nar.Streamer where + +import Control.Monad (forM, forM_, when) +import qualified Control.Monad.IO.Class as IO +import Data.Bool (bool) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BSL +import qualified Data.List as List +import qualified Data.Serialize as Serial +import GHC.Int (Int64) +import qualified System.Directory as Directory +import System.FilePath (()) + +import qualified System.Nix.Internal.Nar.Effects as Nar + + +-- | This implementation of Nar encoding takes an arbitrary @yield@ +-- function from any streaming library, and repeatedly calls +-- it while traversing the filesystem object to Nar encode +streamNarIO + :: forall m.(IO.MonadIO m) + => (BS.ByteString -> m ()) + -> Nar.NarEffects IO + -> FilePath + -> m () +streamNarIO yield effs basePath = do + yield (str "nix-archive-1") + parens (go basePath) + where + + go :: FilePath -> m () + go path = do + isDir <- IO.liftIO $ Nar.narIsDir effs path + isSymLink <- IO.liftIO $ Nar.narIsSymLink effs path + let isRegular = not (isDir || isSymLink) + + when isSymLink $ do + target <- IO.liftIO $ Nar.narReadLink effs path + yield $ + strs ["type", "symlink", "target", BSC.pack target] + + when isRegular $ do + isExec <- IO.liftIO $ isExecutable effs path + yield $ strs ["type","regular"] + when (isExec == Executable) (yield $ strs ["executable", ""]) + fSize <- IO.liftIO $ Nar.narFileSize effs path + yield $ str "contents" + yield $ int fSize + yieldFile path fSize + + when isDir $ do + fs <- IO.liftIO (Nar.narListDir effs path) + yield $ strs ["type", "directory"] + forM_ (List.sort fs) $ \f -> do + yield $ str "entry" + parens $ do + let fullName = path f + yield (strs ["name", BSC.pack f, "node"]) + parens (go fullName) + + str :: BS.ByteString -> BS.ByteString + str t = let len = BS.length t + in int len <> padBS len t + + padBS :: Int -> BS.ByteString -> BS.ByteString + padBS strSize bs = bs <> BS.replicate (padLen strSize) 0 + + parens act = do + yield (str "(") + r <- act + yield (str ")") + return r + + -- Read, yield, and pad the file + yieldFile :: FilePath -> Int64 -> m () + yieldFile path fsize = do + mapM_ yield . BSL.toChunks =<< IO.liftIO (BSL.readFile path) + yield (BS.replicate (padLen (fromIntegral fsize)) 0) + + strs :: [BS.ByteString] -> BS.ByteString + strs xs = BS.concat $ str <$> xs + + int :: Integral a => a -> BS.ByteString + int n = Serial.runPut $ Serial.putInt64le (fromIntegral n) + + +data IsExecutable = NonExecutable | Executable + deriving (Eq, Show) + +isExecutable :: Functor m => Nar.NarEffects m -> FilePath -> m IsExecutable +isExecutable effs fp = + bool NonExecutable Executable . Directory.executable <$> Nar.narGetPerms effs fp + +-- | Distance to the next multiple of 8 +padLen:: Int -> Int +padLen n = (8 - n) `mod` 8 diff --git a/src/System/Nix/Internal/StorePath.hs b/src/System/Nix/Internal/StorePath.hs --- a/src/System/Nix/Internal/StorePath.hs +++ b/src/System/Nix/Internal/StorePath.hs @@ -16,20 +16,28 @@ ( HashAlgorithm(Truncated, SHA256) , Digest , encodeBase32 + , decodeBase32 , SomeNamedDigest ) -import Text.Regex.Base.RegexLike (makeRegex, matchTest) -import Text.Regex.TDFA.Text (Regex) +import System.Nix.Internal.Base32 (digits32) + import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text as T import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BC +import qualified Data.Char import Data.Hashable (Hashable(..)) import Data.HashSet (HashSet) import Data.Proxy (Proxy(..)) +import Data.Attoparsec.Text.Lazy (Parser, ()) + +import qualified Data.Attoparsec.Text.Lazy +import qualified System.FilePath + -- | A path in a Nix store. -- -- From the Nix thesis: A store path is the full path of a store @@ -39,7 +47,7 @@ -- -- See the 'StoreDir' haddocks for details on why we represent this at -- the type level. -data StorePath (storeDir :: StoreDir) = StorePath +data StorePath = StorePath { -- | The 160-bit hash digest reflecting the "address" of the name. -- Currently, this is a truncated SHA256 hash. storePathHash :: !(Digest StorePathHashAlgo) @@ -47,12 +55,17 @@ -- this is typically the package name and version (e.g. -- hello-1.2.3). storePathName :: !StorePathName + , -- | Root of the store + storePathRoot :: !FilePath } deriving (Eq, Ord) -instance Hashable (StorePath storeDir) where +instance Hashable StorePath where hashWithSalt s (StorePath {..}) = s `hashWithSalt` storePathHash `hashWithSalt` storePathName +instance Show StorePath where + show p = BC.unpack $ storePathToRawFilePath p + -- | The name portion of a Nix path. -- -- 'unStorePathName' must only contain a-zA-Z0-9+._?=-, can't start @@ -67,7 +80,7 @@ type StorePathHashAlgo = 'Truncated 20 'SHA256 -- | A set of 'StorePath's. -type StorePathSet storeDir = HashSet (StorePath storeDir) +type StorePathSet = HashSet StorePath -- | An address for a content-addressable store path, i.e. one whose -- store path hash is purely a function of its contents (as opposed to @@ -99,83 +112,40 @@ -- file if so desired. Recursive --- | A type-level representation of the root directory of a Nix store. --- --- The extra complexity of type indices requires justification. --- Fundamentally, this boils down to the fact that there is little --- meaningful sense in which 'StorePath's rooted at different --- directories are of the same type, i.e. there are few if any --- non-trivial non-contrived functions or data types that could --- equally well accept 'StorePath's from different stores. In current --- practice, any real application dealing with Nix stores (including, --- in particular, the Nix expression language) only operates over one --- store root and only cares about 'StorePath's belonging to that --- root. One could imagine a use case that cares about multiple store --- roots at once (e.g. the normal \/nix\/store along with some private --- store at \/root\/nix\/store to contain secrets), but in that case --- distinguishing 'StorePath's that belong to one store or the other --- is even /more/ critical: Most operations will only be correct over --- one of the stores or another, and it would be an error to mix and --- match (e.g. a 'StorePath' in one store could not legitimately refer --- to one in another). --- --- As of @5886bc5996537fbf00d1fcfbb29595b8ccc9743e@, the C++ Nix --- codebase contains 30 separate places where we assert that a given --- store dir is, in fact, in the store we care about; those run-time --- assertions could be completely removed if we had stronger types --- there. Moreover, there are dozens of other cases where input coming --- from the user, from serializations, etc. is parsed and then --- required to be in the appropriate store; this case is the --- equivalent of an existentially quantified version of 'StorePath' --- and, notably, requiring at runtime that the index matches the --- ambient store directory we're working in. In every case where a --- path is treated as a store path, there is exactly one legitimate --- candidate for the store directory it belongs to. --- --- It may be instructive to consider the example of "chroot stores". --- Since Nix 2.0, it has been possible to have a store actually live --- at one directory (say, $HOME\/nix\/store) with a different --- effective store directory (say, \/nix\/store). Nix can build into --- a chroot store by running the builds in a mount namespace where the --- store is at the effective store directory, can download from a --- binary cache containing paths for the effective store directory, --- and can run programs in the store that expect to be living at the --- effective store directory (via nix run). When viewed as store paths --- (rather than random files in the filesystem), paths in a chroot --- store have nothing in common with paths in a non-chroot store that --- lives in the same directory, and a lot in common with paths in a --- non-chroot store that lives in the effective store directory of the --- store in question. Store paths in stores with the same effective --- store directory share the same hashing scheme, can be copied --- between each other, etc. Store paths in stores with different --- effective store directories have no relationship to each other that --- they don't have to arbitrary other files. -type StoreDir = Symbol +makeStorePathName :: Text -> Either String StorePathName +makeStorePathName n = case validStorePathName n of + True -> Right $ StorePathName n + False -> Left $ reasonInvalid n --- | Smart constructor for 'StorePathName' that ensures the underlying --- content invariant is met. -makeStorePathName :: Text -> Maybe StorePathName -makeStorePathName n = case matchTest storePathNameRegex n of - True -> Just $ StorePathName n - False -> Nothing +reasonInvalid :: Text -> String +reasonInvalid n | n == "" = "Empty name" +reasonInvalid n | (T.length n > 211) = "Path too long" +reasonInvalid n | (T.head n == '.') = "Leading dot" +reasonInvalid n | otherwise = "Invalid character" --- | Regular expression to match valid store path names. -storePathNameRegex :: Regex -storePathNameRegex = makeRegex r - where - r :: String - r = "[a-zA-Z0-9\\+\\-\\_\\?\\=][a-zA-Z0-9\\+\\-\\.\\_\\?\\=]*" +validStorePathName :: Text -> Bool +validStorePathName "" = False +validStorePathName n = (T.length n <= 211) + && T.head n /= '.' + && T.all validStorePathNameChar n +validStorePathNameChar :: Char -> Bool +validStorePathNameChar c = any ($ c) $ + [ Data.Char.isAsciiLower -- 'a'..'z' + , Data.Char.isAsciiUpper -- 'A'..'Z' + , Data.Char.isDigit + ] ++ + map (==) "+-._?=" + -- | Copied from @RawFilePath@ in the @unix@ package, duplicated here -- to avoid the dependency. type RawFilePath = ByteString -- | Render a 'StorePath' as a 'RawFilePath'. storePathToRawFilePath - :: forall storeDir . (KnownStoreDir storeDir) - => StorePath storeDir + :: StorePath -> RawFilePath -storePathToRawFilePath (StorePath {..}) = BS.concat +storePathToRawFilePath StorePath {..} = BS.concat [ root , "/" , hashPart @@ -183,19 +153,75 @@ , name ] where - root = storeDirVal @storeDir + root = BC.pack storePathRoot hashPart = encodeUtf8 $ encodeBase32 storePathHash name = encodeUtf8 $ unStorePathName storePathName --- | Get a value-level representation of a 'KnownStoreDir' -storeDirVal :: forall storeDir . (KnownStoreDir storeDir) - => ByteString -storeDirVal = BC.pack $ symbolVal @storeDir Proxy +-- | Render a 'StorePath' as a 'FilePath'. +storePathToFilePath + :: StorePath + -> FilePath +storePathToFilePath = BC.unpack . storePathToRawFilePath --- | A 'StoreDir' whose value is known at compile time. --- --- A valid instance of 'KnownStoreDir' should represent a valid path, --- i.e. all "characters" fit into bytes (as determined by the logic of --- 'BC.pack') and there are no 0 "characters". Currently this is not --- enforced, but it should be. -type KnownStoreDir = KnownSymbol +-- | Render a 'StorePath' as a 'Text'. +storePathToText + :: StorePath + -> Text +storePathToText = T.pack . BC.unpack . storePathToRawFilePath + +-- | Build `narinfo` suffix from `StorePath` which +-- can be used to query binary caches. +storePathToNarInfo + :: StorePath + -> BC.ByteString +storePathToNarInfo StorePath {..} = BS.concat + [ encodeUtf8 $ encodeBase32 storePathHash + , ".narinfo" + ] + +-- | Parse `StorePath` from `BC.ByteString`, checking +-- that store directory matches `expectedRoot`. +parsePath + :: FilePath + -> BC.ByteString + -> Either String StorePath +parsePath expectedRoot x = + let + (rootDir, fname) = System.FilePath.splitFileName . BC.unpack $ x + (digestPart, namePart) = T.breakOn "-" $ T.pack fname + digest = decodeBase32 digestPart + name = makeStorePathName . T.drop 1 $ namePart + --rootDir' = dropTrailingPathSeparator rootDir + -- cannot use ^^ as it drops multiple slashes /a/b/// -> /a/b + rootDir' = init rootDir + storeDir = if expectedRoot == rootDir' + then Right rootDir' + else Left $ unwords $ [ "Root store dir mismatch, expected", expectedRoot, "got", rootDir'] + in + StorePath <$> digest <*> name <*> storeDir + +pathParser :: FilePath -> Parser StorePath +pathParser expectedRoot = do + Data.Attoparsec.Text.Lazy.string (T.pack expectedRoot) + "Store root mismatch" -- e.g. /nix/store + + Data.Attoparsec.Text.Lazy.char '/' + "Expecting path separator" + + digest <- decodeBase32 + <$> Data.Attoparsec.Text.Lazy.takeWhile1 (\c -> c `elem` digits32) + "Invalid Base32 part" + + Data.Attoparsec.Text.Lazy.char '-' + "Expecting dash (path name separator)" + + c0 <- Data.Attoparsec.Text.Lazy.satisfy (\c -> c /= '.' && validStorePathNameChar c) + "Leading path name character is a dot or invalid character" + + rest <- Data.Attoparsec.Text.Lazy.takeWhile validStorePathNameChar + "Path name contains invalid character" + + let name = makeStorePathName $ T.cons c0 rest + + either fail return + $ StorePath <$> digest <*> name <*> pure expectedRoot diff --git a/src/System/Nix/Nar.hs b/src/System/Nix/Nar.hs --- a/src/System/Nix/Nar.hs +++ b/src/System/Nix/Nar.hs @@ -1,279 +1,81 @@ +{- +Description : Generating and consuming NAR files +Maintainer : Shea Levy +-} + {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} - -{-| -Description : Allowed effects for interacting with Nar files. -Maintainer : Shea Levy -|-} -module System.Nix.Nar ( - FileSystemObject(..) - , IsExecutable (..) - , Nar(..) - , getNar - , localPackNar - , localUnpackNar - , narEffectsIO - , putNar - , FilePathPart(..) - , filePathPart - ) where - -import Control.Applicative -import Control.Monad (replicateM, replicateM_, (<=<)) -import qualified Data.Binary as B -import qualified Data.Binary.Get as B -import qualified Data.Binary.Put as B -import Data.Bool (bool) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC -import qualified Data.ByteString.Lazy as BSL -import Data.Foldable (forM_) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) -import qualified Data.Text as T -import qualified Data.Text.Encoding as E -import Data.Traversable (forM) -import GHC.Int (Int64) -import System.Directory -import System.FilePath -import System.Posix.Files (createSymbolicLink, fileSize, getFileStatus, - isDirectory, readSymbolicLink) - - -data NarEffects (m :: * -> *) = NarEffects { - narReadFile :: FilePath -> m BSL.ByteString - , narWriteFile :: FilePath -> BSL.ByteString -> m () - , narListDir :: FilePath -> m [FilePath] - , narCreateDir :: FilePath -> m () - , narCreateLink :: FilePath -> FilePath -> m () - , narGetPerms :: FilePath -> m Permissions - , narSetPerms :: FilePath -> Permissions -> m () - , narIsDir :: FilePath -> m Bool - , narIsSymLink :: FilePath -> m Bool - , narFileSize :: FilePath -> m Int64 - , narReadLink :: FilePath -> m FilePath -} - - --- Directly taken from Eelco thesis --- https://nixos.org/%7Eeelco/pubs/phd-thesis.pdf - -data Nar = Nar { narFile :: FileSystemObject } - deriving (Eq, Show) - --- | A valid filename or directory name -newtype FilePathPart = FilePathPart { unFilePathPart :: BSC.ByteString } - deriving (Eq, Ord, Show) - --- | Construct FilePathPart from Text by checking that there --- are no '/' or '\\NUL' characters -filePathPart :: BSC.ByteString -> Maybe FilePathPart -filePathPart p = case BSC.any (`elem` ['/', '\NUL']) p of - False -> Just $ FilePathPart p - True -> Nothing - --- | A FileSystemObject (FSO) is an anonymous entity that can be NAR archived -data FileSystemObject = - Regular IsExecutable Int64 BSL.ByteString - -- ^ Reguar file, with its executable state, size (bytes) and contents - | Directory (Map.Map FilePathPart FileSystemObject) - -- ^ Directory with mapping of filenames to sub-FSOs - | SymLink T.Text - -- ^ Symbolic link target - deriving (Eq, Show) - - -data IsExecutable = NonExecutable | Executable - deriving (Eq, Show) - - -instance B.Binary Nar where - get = getNar - put = putNar - ------------------------------------------------------------------------------- --- | Serialize Nar to lazy ByteString -putNar :: Nar -> B.Put -putNar (Nar file) = header <> parens (putFile file) - where - - header = str "nix-archive-1" - - putFile (Regular isExec fSize contents) = - strs ["type", "regular"] - >> (if isExec == Executable - then strs ["executable", ""] - else return ()) - >> putContents fSize contents - - putFile (SymLink target) = - strs ["type", "symlink", "target", BSL.fromStrict $ E.encodeUtf8 target] - - -- toList sorts the entries by FilePathPart before serializing - putFile (Directory entries) = - strs ["type", "directory"] - <> mapM_ putEntry (Map.toList entries) - - putEntry (FilePathPart name, fso) = do - str "entry" - parens $ do - str "name" - str (BSL.fromStrict name) - str "node" - parens (putFile fso) - - parens m = str "(" >> m >> str ")" - - -- Do not use this for file contents - str :: BSL.ByteString -> B.Put - str t = let len = BSL.length t - in int len <> pad len t - - putContents :: Int64 -> BSL.ByteString -> B.Put - putContents fSize bs = str "contents" <> int fSize <> (pad fSize bs) - -- putContents fSize bs = str "contents" <> int (BSL.length bs) <> (pad fSize bs) - - int :: Integral a => a -> B.Put - int n = B.putInt64le $ fromIntegral n - - pad :: Int64 -> BSL.ByteString -> B.Put - pad strSize bs = do - B.putLazyByteString bs - B.putLazyByteString (BSL.replicate (padLen strSize) 0) - - strs :: [BSL.ByteString] -> B.Put - strs = mapM_ str - - ------------------------------------------------------------------------------- --- | Deserialize a Nar from lazy ByteString -getNar :: B.Get Nar -getNar = fmap Nar $ header >> parens getFile - where - - header = assertStr "nix-archive-1" - - - -- Fetch a FileSystemObject - getFile = getRegularFile <|> getDirectory <|> getSymLink - - getRegularFile = do - assertStr "type" - assertStr "regular" - mExecutable <- optional $ Executable <$ (assertStr "executable" - >> assertStr "") - assertStr "contents" - (fSize, contents) <- sizedStr - return $ Regular (fromMaybe NonExecutable mExecutable) fSize contents - - getDirectory = do - assertStr "type" - assertStr "directory" - fs <- many getEntry - return $ Directory (Map.fromList fs) - - getSymLink = do - assertStr "type" - assertStr "symlink" - assertStr "target" - fmap (SymLink . E.decodeUtf8 . BSL.toStrict) str - - getEntry = do - assertStr "entry" - parens $ do - assertStr "name" - name <- E.decodeUtf8 . BSL.toStrict <$> str - assertStr "node" - file <- parens getFile - maybe (fail $ "Bad FilePathPart: " ++ show name) - (return . (,file)) - (filePathPart $ E.encodeUtf8 name) - - -- Fetch a length-prefixed, null-padded string - str = fmap snd sizedStr - - sizedStr = do - n <- B.getInt64le - s <- B.getLazyByteString n - p <- B.getByteString . fromIntegral $ padLen n - return (n,s) - - parens m = assertStr "(" *> m <* assertStr ")" - - assertStr s = do - s' <- str - if s == s' - then return s - else fail "No" +{-# LANGUAGE TypeFamilies #-} --- | Distance to the next multiple of 8 -padLen :: Int64 -> Int64 -padLen n = (8 - n) `mod` 8 - +module System.Nix.Nar ( --- | Unpack a NAR into a non-nix-store directory (e.g. for testing) -localUnpackNar :: Monad m => NarEffects m -> FilePath -> Nar -> m () -localUnpackNar effs basePath (Nar fso) = localUnpackFSO basePath fso + -- * Encoding and Decoding NAR archives + buildNarIO + , unpackNarIO - where + -- * Experimental + , Nar.parseNar + , Nar.testParser + , Nar.testParser' - localUnpackFSO basePath fso = case fso of + -- * Filesystem capabilities used by NAR encoder/decoder + , Nar.NarEffects(..) + , Nar.narEffectsIO - Regular isExec _ bs -> do - (narWriteFile effs) basePath bs - p <- narGetPerms effs basePath - (narSetPerms effs) basePath (p {executable = isExec == Executable}) + -- * Internal + , Nar.streamNarIO + , Nar.runParser + ) where - SymLink targ -> narCreateLink effs (T.unpack targ) basePath +import qualified Control.Concurrent as Concurrent +import Control.Monad (when) +import qualified Control.Monad.IO.Class as IO +import Data.Bool (bool) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BSL +import Data.Foldable (forM_) +import qualified Data.List as List +import Data.Monoid ((<>)) +import qualified Data.Serialize.Put as Serial +import GHC.Int (Int64) +import qualified System.Directory as Directory +import System.FilePath as FilePath +import qualified System.IO as IO - Directory contents -> do - narCreateDir effs basePath - forM_ (Map.toList contents) $ \(FilePathPart path', fso) -> - localUnpackFSO (basePath BSC.unpack path') fso +import qualified System.Nix.Internal.Nar.Effects as Nar +import qualified System.Nix.Internal.Nar.Parser as Nar +import qualified System.Nix.Internal.Nar.Streamer as Nar --- | Pack a NAR from a filepath -localPackNar :: Monad m => NarEffects m -> FilePath -> m Nar -localPackNar effs basePath = Nar <$> localPackFSO basePath - - where - - localPackFSO path' = do - fType <- (,) <$> narIsDir effs path' <*> narIsSymLink effs path' - case fType of - (_, True) -> SymLink . T.pack <$> narReadLink effs path' - (False, _) -> Regular <$> isExecutable effs path' - <*> narFileSize effs path' - <*> narReadFile effs path' - (True , _) -> fmap (Directory . Map.fromList) $ do - fs <- narListDir effs path' - forM fs $ \fp -> - (FilePathPart (BSC.pack $ fp),) <$> localPackFSO (path' fp) - +-- For a description of the NAR format, see Eelco's thesis +-- https://nixos.org/%7Eeelco/pubs/phd-thesis.pdf -narEffectsIO :: NarEffects IO -narEffectsIO = NarEffects { - narReadFile = BSL.readFile - , narWriteFile = BSL.writeFile - , narListDir = listDirectory - , narCreateDir = createDirectory - , narCreateLink = createSymbolicLink - , narGetPerms = getPermissions - , narSetPerms = setPermissions - , narIsDir = fmap isDirectory <$> getFileStatus - , narIsSymLink = pathIsSymbolicLink - , narFileSize = fmap (fromIntegral . fileSize) <$> getFileStatus - , narReadLink = readSymbolicLink - } +-- | Pack the filesystem object at @FilePath@ into a NAR and stream it into the +-- @IO.Handle@ +-- The handle should aleady be open and in @IO.WriteMode@. +buildNarIO + :: Nar.NarEffects IO + -> FilePath + -> IO.Handle + -> IO () +buildNarIO effs basePath outHandle = do + Nar.streamNarIO (\chunk -> BS.hPut outHandle chunk >> Concurrent.threadDelay 10) effs basePath -isExecutable :: Functor m => NarEffects m -> FilePath -> m IsExecutable -isExecutable effs fp = - bool NonExecutable Executable . executable <$> narGetPerms effs fp +-- | Read NAR formatted bytes from the @IO.Handle@ and unpack them into +-- file system object(s) at the supplied @FilePath@ +unpackNarIO + :: Nar.NarEffects IO + -> IO.Handle + -> FilePath + -> IO (Either String ()) +unpackNarIO effs narHandle outputFile = do + Nar.runParser effs Nar.parseNar narHandle outputFile diff --git a/src/System/Nix/ReadonlyStore.hs b/src/System/Nix/ReadonlyStore.hs --- a/src/System/Nix/ReadonlyStore.hs +++ b/src/System/Nix/ReadonlyStore.hs @@ -6,27 +6,46 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import qualified Data.Text as T import qualified Data.HashSet as HS import Data.Text.Encoding import System.Nix.Hash import System.Nix.StorePath -makeStorePath :: forall storeDir hashAlgo . (KnownStoreDir storeDir, NamedAlgo hashAlgo) => ByteString -> Digest hashAlgo -> StorePathName -> StorePath storeDir -makeStorePath ty h nm = StorePath storeHash nm +makeStorePath :: forall hashAlgo . (NamedAlgo hashAlgo) + => FilePath + -> ByteString + -> Digest hashAlgo + -> StorePathName + -> StorePath +makeStorePath fp ty h nm = StorePath storeHash nm fp where s = BS.intercalate ":" [ ty , encodeUtf8 $ algoName @hashAlgo , encodeUtf8 $ encodeBase16 h - , storeDirVal @storeDir + , encodeUtf8 $ T.pack fp , encodeUtf8 $ unStorePathName nm ] storeHash = hash s -makeTextPath :: (KnownStoreDir storeDir) => StorePathName -> Digest 'SHA256 -> StorePathSet storeDir -> StorePath storeDir -makeTextPath nm h refs = makeStorePath ty h nm +makeTextPath :: FilePath -> StorePathName -> Digest 'SHA256 -> StorePathSet -> StorePath +makeTextPath fp nm h refs = makeStorePath fp ty h nm where ty = BS.intercalate ":" ("text" : map storePathToRawFilePath (HS.toList refs)) -computeStorePathForText :: (KnownStoreDir storeDir) => StorePathName -> ByteString -> StorePathSet storeDir -> StorePath storeDir -computeStorePathForText nm s refs = makeTextPath nm (hash s) refs +makeFixedOutputPath :: forall hashAlgo . (ValidAlgo hashAlgo, NamedAlgo hashAlgo) + => FilePath + -> Bool + -> Digest hashAlgo + -> StorePathName + -> StorePath +makeFixedOutputPath fp recursive h nm = + if recursive && (algoName @hashAlgo) == "sha256" + then makeStorePath fp "source" h nm + else makeStorePath fp "output:out" h' nm + where + h' = hash @'SHA256 $ "fixed:out:" <> encodeUtf8 (algoName @hashAlgo) <> (if recursive then ":r:" else ":") <> encodeUtf8 (encodeBase16 h) <> ":" + +computeStorePathForText :: FilePath -> StorePathName -> ByteString -> StorePathSet -> StorePath +computeStorePathForText fp nm s refs = makeTextPath fp nm (hash s) refs diff --git a/src/System/Nix/StorePath.hs b/src/System/Nix/StorePath.hs --- a/src/System/Nix/StorePath.hs +++ b/src/System/Nix/StorePath.hs @@ -7,17 +7,20 @@ , StorePathName , StorePathSet , StorePathHashAlgo - , StoreDir , ContentAddressableAddress(..) , NarHashMode(..) , -- * Manipulating 'StorePathName' makeStorePathName , unStorePathName - , storePathNameRegex + , validStorePathName , -- * Rendering out 'StorePath's - storePathToRawFilePath - , storeDirVal - , KnownStoreDir + storePathToFilePath + , storePathToRawFilePath + , storePathToText + , storePathToNarInfo + , -- * Parsing 'StorePath's + parsePath + , pathParser ) where import System.Nix.Internal.StorePath diff --git a/src/System/Nix/StorePathMetadata.hs b/src/System/Nix/StorePathMetadata.hs --- a/src/System/Nix/StorePathMetadata.hs +++ b/src/System/Nix/StorePathMetadata.hs @@ -10,18 +10,18 @@ import Data.Word (Word64) import System.Nix.Signature (NarSignature) --- | Metadata about a 'StorePath' in @storeDir@. -data StorePathMetadata storeDir = StorePathMetadata +-- | Metadata about a 'StorePath' +data StorePathMetadata = StorePathMetadata { -- | The path this metadata is about - path :: !(StorePath storeDir) + path :: !StorePath , -- | The path to the derivation file that built this path, if any -- and known. - deriverPath :: !(Maybe (StorePath storeDir)) + deriverPath :: !(Maybe StorePath) , -- TODO should this be optional? -- | The hash of the nar serialization of the path. narHash :: !SomeNamedDigest , -- | The paths that this path directly references - references :: !(StorePathSet storeDir) + references :: !StorePathSet , -- | When was this path registered valid in the store? registrationTime :: !UTCTime , -- | The size of the nar serialization of the path, in bytes. @@ -47,3 +47,4 @@ | -- | It was built elsewhere (and substituted or similar) and so -- is less trusted BuiltElsewhere + deriving (Show, Eq, Ord) diff --git a/src/System/Nix/Util.hs b/src/System/Nix/Util.hs deleted file mode 100644 --- a/src/System/Nix/Util.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-| -Description : Utilities for packing stuff -Maintainer : srk -|-} -module System.Nix.Util where - -import Control.Monad -import Data.Binary.Get -import Data.Binary.Put -import qualified Data.ByteString.Lazy as LBS - -putInt :: Integral a => a -> Put -putInt = putWord64le . fromIntegral - -getInt :: Integral a => Get a -getInt = fromIntegral <$> getWord64le - --- length prefixed string packing with padding to 8 bytes -putByteStringLen :: LBS.ByteString -> Put -putByteStringLen x = do - putInt $ fromIntegral $ len - putLazyByteString x - when (len `mod` 8 /= 0) $ - pad $ fromIntegral $ 8 - (len `mod` 8) - where len = LBS.length x - pad x = forM_ (take x $ cycle [0]) putWord8 - -putByteStrings :: Foldable t => t LBS.ByteString -> Put -putByteStrings xs = do - putInt $ fromIntegral $ length xs - mapM_ putByteStringLen xs - -getByteStringLen :: Get LBS.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 st - where unpad x = sequence $ replicate x getWord8 - -getByteStrings :: Get [LBS.ByteString] -getByteStrings = do - count <- getInt - res <- sequence $ replicate count getByteStringLen - return res - diff --git a/tests/Arbitrary.hs b/tests/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/tests/Arbitrary.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} + +module Arbitrary where + +import Control.Monad (replicateM) +import qualified Data.ByteString.Char8 as BSC +import qualified Data.Text as T + +import Test.Tasty.QuickCheck + +import System.Nix.Hash +import System.Nix.Internal.Hash +import System.Nix.StorePath +import System.Nix.Internal.StorePath + +genSafeChar :: Gen Char +genSafeChar = choose ('\1', '\127') -- ASCII without \NUL + +nonEmptyString :: Gen String +nonEmptyString = listOf1 genSafeChar + +dir = ('/':) <$> (listOf1 $ elements $ ('/':['a'..'z'])) + +instance Arbitrary StorePathName where + arbitrary = StorePathName . T.pack + <$> ((:) <$> s1 <*> listOf sn) + where + alphanum = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] + s1 = elements $ alphanum ++ "+-_?=" + sn = elements $ alphanum ++ "+-._?=" + +instance Arbitrary (Digest StorePathHashAlgo) where + arbitrary = hash . BSC.pack <$> arbitrary + +instance Arbitrary (Digest SHA256) where + arbitrary = hash . BSC.pack <$> arbitrary + +newtype NixLike = NixLike {getNixLike :: StorePath} + deriving (Eq, Ord, Show) + +instance Arbitrary (NixLike) where + arbitrary = NixLike <$> + (StorePath + <$> arbitraryTruncatedDigest + <*> arbitrary + <*> pure "/nix/store") + where + -- 160-bit hash, 20 bytes, 32 chars in base32 + arbitraryTruncatedDigest = Digest . BSC.pack + <$> replicateM 20 genSafeChar + +instance Arbitrary StorePath where + arbitrary = StorePath + <$> arbitrary + <*> arbitrary + <*> dir diff --git a/tests/Derivation.hs b/tests/Derivation.hs new file mode 100644 --- /dev/null +++ b/tests/Derivation.hs @@ -0,0 +1,36 @@ + +module Derivation where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Golden (goldenVsFile) + +import System.Nix.Derivation (parseDerivation, buildDerivation) + +import qualified Data.Attoparsec.Text.Lazy +import qualified Data.Text.IO +import qualified Data.Text.Lazy +import qualified Data.Text.Lazy.Builder + +processDerivation source dest = do + contents <- Data.Text.IO.readFile source + case Data.Attoparsec.Text.Lazy.parseOnly (parseDerivation "/nix/store") contents of + Left e -> error e + Right drv -> + Data.Text.IO.writeFile dest + . Data.Text.Lazy.toStrict + . Data.Text.Lazy.Builder.toLazyText + $ buildDerivation drv + +test_derivation :: TestTree +test_derivation = testGroup "golden" $ map mk [0..1] + where + mk n = + let + fp = "tests/samples/example" + drv = (fp ++ show n ++ ".drv") + act = (fp ++ show n ++ ".actual") + in + goldenVsFile + ("derivation roundtrip of " ++ drv) + drv act (processDerivation drv act) + diff --git a/tests/Hash.hs b/tests/Hash.hs --- a/tests/Hash.hs +++ b/tests/Hash.hs @@ -5,26 +5,20 @@ module Hash where -import Control.Monad.IO.Class (liftIO) -import Control.Exception (bracket) -import qualified Data.ByteString as BS +import Control.Monad (forM_) +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Base64.Lazy as B64 import qualified Data.ByteString.Lazy as BSL -import Data.Monoid ((<>)) -import qualified Data.Text as T -import System.Directory (removeFile) -import System.IO.Temp (withSystemTempFile, writeSystemTempFile) -import qualified System.IO as IO -- (hGetContents, hPutStr, openFile) -import qualified System.Process as P -import Test.Tasty as T + import Test.Tasty.Hspec -import qualified Test.Tasty.HUnit as HU import Test.Tasty.QuickCheck -import Text.Read (readMaybe) +import System.Nix.Base32 import System.Nix.Hash +import System.Nix.Internal.Hash import System.Nix.StorePath -import NarFormat -- TODO: Move the fixtures into a common module +import Arbitrary spec_hash :: Spec spec_hash = do @@ -34,7 +28,9 @@ it "produces (base32 . sha256) of \"nix-output:foo\" the same as Nix does at the moment for placeholder \"foo\"" $ shouldBe (encodeBase32 (hash @SHA256 "nix-output:foo")) "1x0ymrsy7yr7i9wdsqy9khmzc1yy7nvxw6rdp72yzn50285s67j5" - + it "produces (base16 . md5) of \"Hello World\" the same as the thesis" $ + shouldBe (encodeBase16 (hash @MD5 "Hello World")) + "b10a8db164e0754105b7a99be72e3fe5" it "produces (base32 . sha1) of \"Hello World\" the same as the thesis" $ shouldBe (encodeBase32 (hash @SHA1 "Hello World")) "s23c9fs0v32pf6bhmcph5rbqsyl5ak8a" @@ -47,3 +43,52 @@ <> "c0d7b98883f9ee3:/nix/store:myfile" shouldBe (encodeBase32 @StorePathHashAlgo (hash exampleStr)) "xv2iccirbrvklck36f1g7vldn5v58vck" + +-- | Test that Nix-like base32 encoding roundtrips +prop_nixBase32Roundtrip = forAllShrink nonEmptyString genericShrink $ + \x -> Right (BSC.pack x) === (decode . encode . BSC.pack $ x) + +-- | API variants +prop_nixBase16Roundtrip = + \(x :: Digest StorePathHashAlgo) -> Right x === (decodeBase16 . encodeBase16 $ x) + +-- | Hash encoding conversion ground-truth. +-- Similiar to nix/tests/hash.sh +spec_nixhash :: Spec +spec_nixhash = do + + describe "hashing parity with nix-nash" $ do + + let + samples = [ + ( "800d59cfcd3c05e900cb4e214be48f6b886a08df" + , "vw46m23bizj4n8afrc0fj19wrp7mj3c0" + , "gA1Zz808BekAy04hS+SPa4hqCN8=" + ) + , ( "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" + , "1b8m03r63zqhnjf7l5wnldhh7c134ap5vpj0850ymkq1iyzicy5s" + , "ungWv48Bz+pBQUDeXa4iI7ADYaOWF3qctBD/YfIAFa0=" + ) + , ( "204a8fc6dda82f0a0ced7beb8e08a41657c16ef468b228a8279be331a703c33596fd15c13b1b07f9aa1d3bea57789ca031ad85c7a71dd70354ec631238ca3445" + , "12k9jiq29iyqm03swfsgiw5mlqs173qazm3n7daz43infy12pyrcdf30fkk3qwv4yl2ick8yipc2mqnlh48xsvvxl60lbx8vp38yji0" + , "IEqPxt2oLwoM7XvrjgikFlfBbvRosiioJ5vjMacDwzWW/RXBOxsH+aodO+pXeJygMa2Fx6cd1wNU7GMSOMo0RQ==" + ) + ] + + it "b16 encoded . b32 decoded should equal original b16" $ + forM_ samples $ \(b16, b32, b64) -> shouldBe (B16.encode <$> decode b32) (Right b16) + + it "b64 encoded . b32 decoded should equal original b64" $ + forM_ samples $ \(b16, b32, b64) -> shouldBe (B64.encode . BSL.fromStrict <$> decode b32) (Right b64) + + it "b32 encoded . b64 decoded should equal original b32" $ + forM_ samples $ \(b16, b32, b64) -> shouldBe (encode . BSL.toStrict <$> B64.decode b64 ) (Right b32) + + it "b16 encoded . b64 decoded should equal original b16" $ + forM_ samples $ \(b16, b32, b64) -> shouldBe (B16.encode . BSL.toStrict <$> B64.decode b64 ) (Right b16) + + it "b32 encoded . b16 decoded should equal original b32" $ + forM_ samples $ \(b16, b32, b64) -> shouldBe (encode $ fst $ B16.decode b16 ) b32 + + it "b64 encoded . b16 decoded should equal original b64" $ + forM_ samples $ \(b16, b32, b64) -> shouldBe (B64.encode $ BSL.fromStrict $ fst $ B16.decode b16 ) b64 diff --git a/tests/NarFormat.hs b/tests/NarFormat.hs --- a/tests/NarFormat.hs +++ b/tests/NarFormat.hs @@ -2,67 +2,116 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} module NarFormat where -import Control.Applicative ((<|>)) -import Control.Concurrent (threadDelay) -import Control.Exception (SomeException, bracket, try) -import Control.Monad (replicateM) -import Control.Monad.IO.Class (liftIO) -import Data.Binary (put) -import Data.Binary.Get (Get (..), runGet) -import Data.Binary.Put (Put (..), runPut) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base64.Lazy as B64 -import qualified Data.ByteString.Char8 as BSC -import qualified Data.ByteString.Lazy as BSL -import qualified Data.ByteString.Lazy.Char8 as BSLC +import Control.Applicative (many, optional, (<|>)) +import Control.Concurrent (threadDelay) +import qualified Control.Concurrent as Concurrent +import Control.Exception (SomeException, finally, try) +import Control.Monad (replicateM, replicateM_, + when) +import Control.Monad.IO.Class (liftIO) +import Data.Binary (put) +import Data.Binary.Get (Get (..), getByteString, + getInt64le, + getLazyByteString, runGet) +import Data.Binary.Put (Put (..), putInt64le, + putLazyByteString, runPut) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64.Lazy as B64 +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSLC import Data.Int -import qualified Data.Map as Map -import Data.Maybe (fromMaybe, isJust) -import qualified Data.Text as T -import GHC.Stats (getRTSStats, max_live_bytes) -import System.Directory (removeFile) -import System.Environment (getEnv) -import qualified System.Process as P -import Test.Tasty as T +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, isJust) +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import GHC.Stats (getRTSStats, max_live_bytes) +import System.Directory (doesDirectoryExist, + doesFileExist, doesPathExist, + listDirectory, + removeDirectoryRecursive, + removeFile) +import qualified System.Directory as Directory +import System.Environment (getEnv) +import System.FilePath ((<.>), ()) +import qualified System.IO as IO +import qualified System.IO.Streams.File as IOStreamsFile +import qualified System.IO.Streams.Process as IOStreamsProcess +import qualified System.IO.Temp as Temp +import qualified System.Posix.Process as Unix +import qualified System.Process as P +import qualified System.Process.ByteString.Lazy as ProcessByteString +import Test.Tasty as T import Test.Tasty.Hspec -import qualified Test.Tasty.HUnit as HU +import qualified Test.Tasty.HUnit as HU import Test.Tasty.QuickCheck -import Text.Read (readMaybe) +import qualified Text.Printf as Printf +import Text.Read (readMaybe) +import qualified System.Nix.Internal.Nar.Streamer as Nar import System.Nix.Nar +withBytesAsHandle bytes act = do + Temp.withSystemTempFile "nar-test-file-XXXXX" $ \tmpFile h -> do + IO.hClose h + BSL.writeFile tmpFile bytes + IO.withFile tmpFile IO.ReadMode act + spec_narEncoding :: Spec spec_narEncoding = do -- For a Haskell embedded Nar, check that (decode . encode === id) - let roundTrip n = runGet getNar (runPut $ putNar n) `shouldBe` n + let + withTempDir act = Temp.withSystemTempDirectory "nar-test" act + + roundTrip :: String -> Nar -> IO () + roundTrip narFileName n = withTempDir $ \tmpDir -> do + let packageFilePath = tmpDir narFileName + + e <- doesPathExist packageFilePath + e `shouldBe` False + + res <- withBytesAsHandle (runPut (putNar n)) $ \h -> do + unpackNarIO narEffectsIO h packageFilePath + res `shouldBe` Right () + + e <- doesPathExist packageFilePath + e `shouldBe` True + + res <- Temp.withSystemTempFile "nar-test-file-hnix" $ \tmpFile h -> do + buildNarIO narEffectsIO packageFilePath h + IO.hClose h + BSL.readFile tmpFile + + res `shouldBe` (runPut $ putNar n) + -- For a Haskell embedded Nar, check that encoding it gives -- the same bytestring as `nix-store --dump` - let encEqualsNixStore n b = runPut (putNar n) `shouldBe` b + let + encEqualsNixStore :: Nar -> BSL.ByteString -> IO () + encEqualsNixStore n b = runPut (putNar n) `shouldBe` b describe "parser-roundtrip" $ do it "roundtrips regular" $ do - roundTrip (Nar sampleRegular) + roundTrip "sampleRegular" (Nar sampleRegular) it "roundtrips regular 2" $ do - roundTrip (Nar sampleRegular') + roundTrip "sampleRegular'" (Nar sampleRegular') it "roundtrips executable" $ do - roundTrip (Nar sampleExecutable) - - it "roundtrips symlink" $ do - roundTrip (Nar sampleSymLink) + roundTrip "sampleExecutable" (Nar sampleExecutable) it "roundtrips directory" $ do - roundTrip (Nar sampleDirectory) - + roundTrip "sampleDirectory" (Nar sampleDirectory) describe "matches-nix-store fixture" $ do it "matches regular" $ do @@ -80,6 +129,7 @@ it "matches directory" $ do encEqualsNixStore (Nar sampleDirectory) sampleDirectoryBaseline + unit_nixStoreRegular :: HU.Assertion unit_nixStoreRegular = filesystemNixStore "regular" (Nar sampleRegular) @@ -89,44 +139,139 @@ unit_nixStoreDirectory' :: HU.Assertion unit_nixStoreDirectory' = filesystemNixStore "directory'" (Nar sampleDirectory') -unit_nixStoreBigFile :: HU.Assertion -unit_nixStoreBigFile = getBigFileSize >>= \sz -> - filesystemNixStore "bigfile'" (Nar $ sampleLargeFile sz) +test_nixStoreBigFile :: TestTree +test_nixStoreBigFile = packThenExtract "bigfile" $ \baseDir -> do + mkBigFile (baseDir "bigfile") -unit_nixStoreBigDir :: HU.Assertion -unit_nixStoreBigDir = getBigFileSize >>= \sz -> - filesystemNixStore "bigfile'" (Nar $ sampleLargeDir sz) +test_nixStoreBigDir :: TestTree +test_nixStoreBigDir = packThenExtract "bigdir" $ \baseDir -> do + let testDir = baseDir "bigdir" + Directory.createDirectory testDir + mkBigFile (testDir "bf1") + mkBigFile (testDir "bf2") + -- flip mapM_ [1..100] $ \i -> + -- mkBigFile (testDir ('f': show i)) + -- -- Directory.createDirectory (testDir "") + + prop_narEncodingArbitrary :: Nar -> Property prop_narEncodingArbitrary n = runGet getNar (runPut $ putNar n) === n unit_packSelfSrcDir :: HU.Assertion -unit_packSelfSrcDir = do +unit_packSelfSrcDir = Temp.withSystemTempDirectory "nar-test" $ \tmpDir -> do ver <- try (P.readProcess "nix-store" ["--version"] "") + let narFile = tmpDir "src.nar" case ver of Left (e :: SomeException) -> print "No nix-store on system" Right _ -> do - hnixNar <- runPut . put <$> localPackNar narEffectsIO "src" - nixStoreNar <- getNixStoreDump "src" - HU.assertEqual - "src dir serializes the same between hnix-store and nix-store" - hnixNar - nixStoreNar + let go dir = do + srcHere <- doesDirectoryExist dir + case srcHere of + False -> return () + True -> do + IO.withFile narFile IO.WriteMode $ \h -> + buildNarIO narEffectsIO "src" h + hnixNar <- BSL.readFile narFile + nixStoreNar <- getNixStoreDump "src" + HU.assertEqual + "src dir serializes the same between hnix-store and nix-store" + hnixNar + nixStoreNar + go "src" + go "hnix-store-core/src" +-- ||||||| merged common ancestors +-- hnixNar <- runPut . put <$> localPackNar narEffectsIO "src" +-- nixStoreNar <- getNixStoreDump "src" +-- HU.assertEqual +-- "src dir serializes the same between hnix-store and nix-store" +-- hnixNar +-- nixStoreNar +-- ======= +-- let narFile = tmpDir "src.nar" +-- IO.withFile narFile IO.WriteMode $ \h -> +-- buildNarIO narEffectsIO "src" h +-- hnixNar <- BSL.readFile narFile +-- nixStoreNar <- getNixStoreDump "src" +-- HU.assertEqual +-- "src dir serializes the same between hnix-store and nix-store" +-- hnixNar +-- nixStoreNar +-- >>>>>>> Use streaming to consume and produce NARs -unit_streamLargeFileToNar :: HU.Assertion -unit_streamLargeFileToNar = - bracket (getBigFileSize >>= makeBigFile) (const rmFiles) $ \_ -> do - nar <- localPackNar narEffectsIO bigFileName - BSL.writeFile narFileName . runPut . put $ nar - assertBoundedMemory +-- passes +test_streamLargeFileToNar :: TestTree +test_streamLargeFileToNar = HU.testCaseSteps "streamLargeFileToNar" $ \step -> do + + step "create test file" + mkBigFile bigFileName + -- BSL.writeFile narFileName =<< buildNarIO narEffectsIO bigFileName + -- + step "create nar file" + IO.withFile narFileName IO.WriteMode $ \h -> + buildNarIO narEffectsIO bigFileName h + + step "assert bounded memory" + assertBoundedMemory + rmFiles where bigFileName = "bigFile.bin" narFileName = "bigFile.nar" - makeBigFile = \sz -> BSL.writeFile bigFileName - (BSL.take sz $ BSL.cycle "Lorem ipsum") rmFiles = removeFile bigFileName >> removeFile narFileName +-------------------------------------------------------------------------------- +test_streamManyFilesToNar :: TestTree +test_streamManyFilesToNar = HU.testCaseSteps "streamManyFilesToNar" $ \step -> + Temp.withSystemTempDirectory "hnix-store" $ \baseDir -> do + let + + packagePath = baseDir "package_with_many_files" + packagePath' = baseDir "package_with_many_files2" + narFile = packagePath <.> "nar" + + rmFiles = try @SomeException @() $ do + e <- doesPathExist narFile + when e $ removeDirectoryRecursive narFile + + run = do + filesPrecount <- countProcessFiles + IO.withFile "hnar" IO.WriteMode $ \h -> + buildNarIO narEffectsIO narFile h + filesPostcount <- countProcessFiles + return $ filesPostcount - filesPrecount + + step "create test files" + Directory.createDirectory packagePath + flip mapM_ [0..1000] $ \i -> do + BSL.writeFile (Printf.printf (packagePath "%08d") (i :: Int)) "hi\n" + Concurrent.threadDelay 50 + + filesPrecount <- countProcessFiles + + step "pack nar" + IO.withFile narFile IO.WriteMode $ \h -> + buildNarIO narEffectsIO packagePath h + + step "unpack nar" + r <- IO.withFile narFile IO.ReadMode $ \h -> + unpackNarIO narEffectsIO h packagePath' + r `shouldBe` Right () + + step "check constant file usage" + filesPostcount <- countProcessFiles + (filesPostcount - filesPrecount) `shouldSatisfy` (< 50) + + -- step "check file exists" + -- e <- doesPathExist packagePath' + -- e `shouldBe` True + + -- step "read the NAR back in" + -- filesCreated <- run `finally` rmFiles + -- filesCreated `shouldSatisfy` (< 50) + + + -- **************** Utilities ************************ -- | Generate the ground-truth encoding on the fly with @@ -140,19 +285,33 @@ -- Left is not an error - testing machine simply doesn't have -- `nix-store` executable, so pass Left (e :: SomeException) -> print "No nix-store on system" - Right _ -> - bracket (return ()) (\_ -> P.runCommand "rm -rf testfile nixstorenar.nar hnix.nar") $ \_ -> do + Right _ -> Temp.withSystemTempDirectory "hnix-store" $ \baseDir -> do + let + testFile = baseDir "testfile" + nixNarFile = baseDir "nixstorenar.nar" + hnixNarFile = baseDir "hnix.nar" + + assertExists f = do + e <- doesPathExist f + e `shouldBe` True + -- stream nar contents to unpacked file(s) - localUnpackNar narEffectsIO "testfile" n + withBytesAsHandle (runPut $ putNar n) $ \h -> + unpackNarIO narEffectsIO h testFile + assertExists testFile + -- nix-store converts those files to nar - getNixStoreDump "testfile" >>= BSL.writeFile "nixstorenar.nar" + getNixStoreDump testFile >>= BSL.writeFile nixNarFile + assertExists nixNarFile -- hnix converts those files to nar - localPackNar narEffectsIO "testfile" >>= BSL.writeFile "hnix.nar" . runPut . putNar + IO.withFile hnixNarFile IO.WriteMode $ \h -> + buildNarIO narEffectsIO testFile h + assertExists hnixNarFile - diffResult <- P.readProcess "diff" ["nixstorenar.nar", "hnix.nar"] "" + diffResult <- P.readProcess "diff" [nixNarFile, hnixNarFile] "" assertBoundedMemory HU.assertEqual testErrorName diffResult "" @@ -169,6 +328,60 @@ #endif +packThenExtract + :: String + -- ^ Test name (will also be used for file name) + -> (String -> IO ()) + -- ^ Action to create some files that we will + -- pack into a NAR + -> TestTree +packThenExtract testName setup = + HU.testCaseSteps testName $ \step -> + Temp.withSystemTempDirectory "hnix-store" $ \baseDir -> do + setup baseDir + + let narFile = baseDir testName + + ver <- try (P.readProcess "nix-store" ["--version"] "") + case ver of + Left (e :: SomeException) -> print "No nix-store on system" + Right _ -> do + let + nixNarFile = narFile ++ ".nix" + hnixNarFile = narFile ++ ".hnix" + outputFile = narFile ++ ".out" + + step $ "Produce nix-store nar to " ++ nixNarFile + (_,_,_,handle) <- P.createProcess (P.shell $ "nix-store --dump " ++ narFile ++ " > " ++ nixNarFile) + P.waitForProcess handle + + step $ "Build NAR from " ++ narFile ++ " to " ++ hnixNarFile + -- narBS <- buildNarIO narEffectsIO narFile + IO.withFile hnixNarFile IO.WriteMode $ \h -> + buildNarIO narEffectsIO narFile h + + -- BSL.writeFile hnixNarFile narBS + + step $ "Unpack NAR to " ++ outputFile + narHandle <- IO.withFile nixNarFile IO.ReadMode $ \h -> + unpackNarIO narEffectsIO h outputFile + + return () + + + + + + +-- | Count file descriptors owned by the current process +countProcessFiles :: IO Int +countProcessFiles = do + pid <- Unix.getProcessID + let fdDir = "/proc/" ++ show pid ++ "/fd" + fds <- P.readProcess "ls" [fdDir] "" + return $ length $ words fds + + -- | Read the binary output of `nix-store --dump` for a filepath getNixStoreDump :: String -> IO BSL.ByteString getNixStoreDump fp = do @@ -182,17 +395,17 @@ -- | Simple regular text file with contents 'hi' sampleRegular :: FileSystemObject -sampleRegular = Regular NonExecutable 3 "hi\n" +sampleRegular = Regular Nar.NonExecutable 3 "hi\n" -- | Simple text file with some c code sampleRegular' :: FileSystemObject -sampleRegular' = Regular NonExecutable (BSL.length str) str +sampleRegular' = Regular Nar.NonExecutable (BSL.length str) str where str = "#include \n\nint main(int argc, char *argv[]){ exit 0; }\n" -- | Executable file sampleExecutable :: FileSystemObject -sampleExecutable = Regular Executable (BSL.length str) str +sampleExecutable = Regular Nar.Executable (BSL.length str) str where str = "#!/bin/bash\n\ngcc -o hello hello.c\n" -- | A simple symlink @@ -213,24 +426,24 @@ sampleDirectory' = Directory $ Map.fromList [ (FilePathPart "foo", Directory $ Map.fromList [ - (FilePathPart "foo.txt", Regular NonExecutable 8 "foo text") + (FilePathPart "foo.txt", Regular Nar.NonExecutable 8 "foo text") , (FilePathPart "tobar" , SymLink "../bar/bar.txt") ]) , (FilePathPart "bar", Directory $ Map.fromList [ - (FilePathPart "bar.txt", Regular NonExecutable 8 "bar text") + (FilePathPart "bar.txt", Regular Nar.NonExecutable 8 "bar text") , (FilePathPart "tofoo" , SymLink "../foo/foo.txt") ]) ] sampleLargeFile :: Int64 -> FileSystemObject sampleLargeFile fSize = - Regular NonExecutable fSize (BSL.take fSize (BSL.cycle "Lorem ipsum ")) + Regular Nar.NonExecutable fSize (BSL.take fSize (BSL.cycle "Lorem ipsum ")) sampleLargeFile' :: Int64 -> FileSystemObject sampleLargeFile' fSize = - Regular NonExecutable fSize (BSL.take fSize (BSL.cycle "Lorems ipsums ")) + Regular Nar.NonExecutable fSize (BSL.take fSize (BSL.cycle "Lorems ipsums ")) sampleLargeDir :: Int64 -> FileSystemObject sampleLargeDir fSize = Directory $ Map.fromList $ [ @@ -238,16 +451,25 @@ , (FilePathPart "bf2", sampleLargeFile' fSize) ] ++ [ (FilePathPart (BSC.pack $ 'f' : show n), - Regular NonExecutable 10000 (BSL.take 10000 (BSL.cycle "hi "))) + Regular Nar.NonExecutable 10000 (BSL.take 10000 (BSL.cycle "hi "))) | n <- [1..100]] ++ [ (FilePathPart "d", Directory $ Map.fromList [ (FilePathPart (BSC.pack $ "df" ++ show n) - , Regular NonExecutable 10000 (BSL.take 10000 (BSL.cycle "subhi "))) + , Regular Nar.NonExecutable 10000 (BSL.take 10000 (BSL.cycle "subhi "))) | n <- [1..100]] ) ] +-------------------------------------------------------------------------------- +sampleDirWithManyFiles :: Int -> FileSystemObject +sampleDirWithManyFiles nFiles = + Directory $ Map.fromList $ mkFile <$> take nFiles [0..] + where + mkFile :: Int -> (FilePathPart, FileSystemObject) + mkFile i = (FilePathPart (BSC.pack (Printf.printf "%08d" i)), + sampleRegular) + -- * For each sample above, feed it into `nix-store --dump`, -- and base64 encode the resulting NAR binary. This lets us -- check our Haskell NAR generator against `nix-store` @@ -315,7 +537,7 @@ -- | Control testcase sizes (bytes) by env variable getBigFileSize :: IO Int64 -getBigFileSize = fromMaybe 1000000 . readMaybe <$> (getEnv "HNIX_BIG_FILE_SIZE" <|> pure "") +getBigFileSize = fromMaybe 5000000 . readMaybe <$> (getEnv "HNIX_BIG_FILE_SIZE" <|> pure "") -- | Add a link to a FileSystemObject. This is useful @@ -328,7 +550,37 @@ -> FileSystemObject mkLink = undefined -- TODO +mkBigFile :: FilePath -> IO () +mkBigFile path = do + fsize <- getBigFileSize + BSL.writeFile path (BSL.take fsize $ BSL.cycle "Lorem ipsum") + +-- | Construct FilePathPart from Text by checking that there +-- are no '/' or '\\NUL' characters +filePathPart :: BSC.ByteString -> Maybe FilePathPart +filePathPart p = case BSC.any (`elem` ['/', '\NUL']) p of + False -> Just $ FilePathPart p + True -> Nothing + +data Nar = Nar { narFile :: FileSystemObject } + deriving (Eq, Show) + +-- | A FileSystemObject (FSO) is an anonymous entity that can be NAR archived +data FileSystemObject = + Regular Nar.IsExecutable Int64 BSL.ByteString + -- ^ Reguar file, with its executable state, size (bytes) and contents + | Directory (Map.Map FilePathPart FileSystemObject) + -- ^ Directory with mapping of filenames to sub-FSOs + | SymLink T.Text + -- ^ Symbolic link target + deriving (Eq, Show) + +-- | A valid filename or directory name +newtype FilePathPart = FilePathPart { unFilePathPart :: BSC.ByteString } + deriving (Eq, Ord, Show) + + instance Arbitrary Nar where arbitrary = Nar <$> resize 10 arbitrary @@ -346,7 +598,7 @@ arbFile = do Positive fSize <- arbitrary Regular - <$> elements [NonExecutable, Executable] + <$> elements [Nar.NonExecutable, Nar.Executable] <*> pure (fromIntegral fSize) <*> oneof [ fmap (BSL.take fSize . BSL.cycle . BSL.pack . getNonEmpty) arbitrary , -- Binary File @@ -363,3 +615,120 @@ nm <- arbName f <- oneof [arbFile, arbDirectory (n `div` 2)] return (nm,f) + +------------------------------------------------------------------------------ +-- | Serialize Nar to lazy ByteString +putNar :: Nar -> Put +putNar (Nar file) = header <> parens (putFile file) + where + + header = str "nix-archive-1" + + putFile (Regular isExec fSize contents) = + strs ["type", "regular"] + >> (if isExec == Nar.Executable + then strs ["executable", ""] + else return ()) + >> putContents fSize contents + + putFile (SymLink target) = + strs ["type", "symlink", "target", BSL.fromStrict $ E.encodeUtf8 target] + + -- toList sorts the entries by FilePathPart before serializing + putFile (Directory entries) = + strs ["type", "directory"] + <> mapM_ putEntry (Map.toList entries) + + putEntry (FilePathPart name, fso) = do + str "entry" + parens $ do + str "name" + str (BSL.fromStrict name) + str "node" + parens (putFile fso) + + parens m = str "(" >> m >> str ")" + + -- Do not use this for file contents + str :: BSL.ByteString -> Put + str t = let len = BSL.length t + in int len <> pad len t + + putContents :: Int64 -> BSL.ByteString -> Put + putContents fSize bs = str "contents" <> int fSize <> (pad fSize bs) + + int :: Integral a => a -> Put + int n = putInt64le $ fromIntegral n + + pad :: Int64 -> BSL.ByteString -> Put + pad strSize bs = do + putLazyByteString bs + putLazyByteString (BSL.replicate (padLen strSize) 0) + + strs :: [BSL.ByteString] -> Put + strs = mapM_ str + +-- | Distance to the next multiple of 8 +padLen :: Int64 -> Int64 +padLen n = (8 - n) `mod` 8 + + +------------------------------------------------------------------------------ +-- | Deserialize a Nar from lazy ByteString +getNar :: Get Nar +getNar = fmap Nar $ header >> parens getFile + where + + header = assertStr "nix-archive-1" + + -- Fetch a FileSystemObject + getFile = getRegularFile <|> getDirectory <|> getSymLink + + getRegularFile = do + assertStr "type" + assertStr "regular" + mExecutable <- optional $ Nar.Executable <$ (assertStr "executable" + >> assertStr "") + assertStr "contents" + (fSize, contents) <- sizedStr + return $ Regular (fromMaybe Nar.NonExecutable mExecutable) fSize contents + + getDirectory = do + assertStr "type" + assertStr "directory" + fs <- many getEntry + return $ Directory (Map.fromList fs) + + getSymLink = do + assertStr "type" + assertStr "symlink" + assertStr "target" + fmap (SymLink . E.decodeUtf8 . BSL.toStrict) str + + getEntry = do + assertStr "entry" + parens $ do + assertStr "name" + name <- E.decodeUtf8 . BSL.toStrict <$> str + assertStr "node" + file <- parens getFile + maybe (fail $ "Bad FilePathPart: " ++ show name) + (return . (,file)) + (filePathPart $ E.encodeUtf8 name) + + -- Fetch a length-prefixed, null-padded string + str = fmap snd sizedStr + + sizedStr = do + n <- getInt64le + s <- getLazyByteString n + p <- getByteString . fromIntegral $ padLen n + return (n,s) + + parens m = assertStr "(" *> m <* assertStr ")" + + assertStr s = do + s' <- str + if s == s' + then return s + else fail "No" diff --git a/tests/StorePath.hs b/tests/StorePath.hs new file mode 100644 --- /dev/null +++ b/tests/StorePath.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module StorePath where + +import qualified Data.Attoparsec.Text.Lazy + +import Test.Tasty.QuickCheck + +import System.Nix.StorePath +import Arbitrary + +-- | Test that Nix(OS) like paths roundtrip +prop_storePathRoundtrip (_ :: NixLike) = \(NixLike x) -> + (parsePath "/nix/store" $ storePathToRawFilePath x) === Right x + +-- | Test that any `StorePath` roundtrips +prop_storePathRoundtrip' x = + (parsePath (storePathRoot x) $ storePathToRawFilePath x) === Right x + +prop_storePathRoundtripParser (_ :: NixLike) = \(NixLike x) -> + (Data.Attoparsec.Text.Lazy.parseOnly (pathParser (storePathRoot x)) + $ storePathToText x) === Right x + +prop_storePathRoundtripParser' x = + (Data.Attoparsec.Text.Lazy.parseOnly (pathParser (storePathRoot x)) + $ storePathToText x) === Right x