hnix-store-core 0.2.0.0 → 0.3.0.0
raw patch · 22 files changed
+1806/−536 lines, 22 filesdep +algebraic-graphsdep +attoparsecdep +cerealdep −regex-basedep −regex-tdfadep ~saltine
Dependencies added: algebraic-graphs, attoparsec, cereal, cryptohash-sha512, io-streams, lifted-base, monad-control, nix-derivation, process-extras, tasty-golden
Dependencies removed: regex-base, regex-tdfa
Dependency ranges changed: saltine
Files
- ChangeLog.md +25/−1
- hnix-store-core.cabal +27/−5
- src/System/Nix/Base32.hs +5/−35
- src/System/Nix/Build.hs +55/−0
- src/System/Nix/Derivation.hs +36/−0
- src/System/Nix/Hash.hs +3/−0
- src/System/Nix/Internal/Base32.hs +82/−0
- src/System/Nix/Internal/Hash.hs +74/−2
- src/System/Nix/Internal/Nar/Effects.hs +95/−0
- src/System/Nix/Internal/Nar/Parser.hs +468/−0
- src/System/Nix/Internal/Nar/Streamer.hs +104/−0
- src/System/Nix/Internal/StorePath.hs +110/−84
- src/System/Nix/Nar.hs +61/−259
- src/System/Nix/ReadonlyStore.hs +26/−7
- src/System/Nix/StorePath.hs +8/−5
- src/System/Nix/StorePathMetadata.hs +6/−5
- src/System/Nix/Util.hs +0/−48
- tests/Arbitrary.hs +57/−0
- tests/Derivation.hs +36/−0
- tests/Hash.hs +59/−14
- tests/NarFormat.hs +440/−71
- tests/StorePath.hs +29/−0
ChangeLog.md view
@@ -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.
hnix-store-core.cabal view
@@ -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
src/System/Nix/Base32.hs view
@@ -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
+ src/System/Nix/Build.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE RecordWildCards #-}+{-|+Description : Build related types+Maintainer : srk <srk@48.io>+|-}+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
+ src/System/Nix/Derivation.hs view
@@ -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
src/System/Nix/Hash.hs view
@@ -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
+ src/System/Nix/Internal/Base32.hs view
@@ -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)
src/System/Nix/Internal/Hash.hs view
@@ -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.
+ src/System/Nix/Internal/Nar/Effects.hs view
@@ -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
+ src/System/Nix/Internal/Nar/Parser.hs view
@@ -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)
+ src/System/Nix/Internal/Nar/Streamer.hs view
@@ -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
src/System/Nix/Internal/StorePath.hs view
@@ -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
src/System/Nix/Nar.hs view
@@ -1,279 +1,81 @@+{-+Description : Generating and consuming NAR files+Maintainer : Shea Levy <shea@shealevy.com>+-}+ {-# 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 <shea@shealevy.com>-|-}-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
src/System/Nix/ReadonlyStore.hs view
@@ -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
src/System/Nix/StorePath.hs view
@@ -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
src/System/Nix/StorePathMetadata.hs view
@@ -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)
− src/System/Nix/Util.hs
@@ -1,48 +0,0 @@-{-|-Description : Utilities for packing stuff-Maintainer : srk <srk@48.io>-|-}-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-
+ tests/Arbitrary.hs view
@@ -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
+ tests/Derivation.hs view
@@ -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)+
tests/Hash.hs view
@@ -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
tests/NarFormat.hs view
@@ -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 <stdio.h>\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"
+ tests/StorePath.hs view
@@ -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