mirror of
https://github.com/haskell-nix/hnix-store.git
synced 2024-09-11 18:05:56 +03:00
Add NAR parser-generator and tests
This commit is contained in:
parent
9b673371a6
commit
7f1928edcb
1
hnix-store-core/.ghci
Executable file
1
hnix-store-core/.ghci
Executable file
@ -0,0 +1 @@
|
||||
:set -itests
|
@ -7,3 +7,9 @@ See `StoreEffects` in [System.Nix.Store] for the available operations
|
||||
on the store.
|
||||
|
||||
[System.Nix.Store]: ./src/System/Nix/Store.hs
|
||||
|
||||
|
||||
Tests
|
||||
======
|
||||
|
||||
- `ghcid --command "cabal repl test-suite:format-tests" --test="Main.main"`
|
||||
|
@ -19,12 +19,51 @@ cabal-version: >=1.10
|
||||
library
|
||||
exposed-modules: Crypto.Hash.Truncated
|
||||
, System.Nix.Nar
|
||||
, System.Nix.Path
|
||||
, System.Nix.Store
|
||||
build-depends: base >=4.10 && <4.11,
|
||||
-- Drop foundation when we can drop cryptonite <0.25
|
||||
binary,
|
||||
bytestring, containers, cryptonite, memory, foundation, basement,
|
||||
text, regex-base, regex-tdfa-text,
|
||||
hashable, unordered-containers, bytestring
|
||||
build-depends: base >=4.10 && <4.11
|
||||
, basement
|
||||
, bytestring
|
||||
, binary
|
||||
, bytestring
|
||||
, containers
|
||||
, cryptonite
|
||||
, directory
|
||||
, filepath
|
||||
-- Drop foundation when we can drop cryptonite <0.25
|
||||
, foundation
|
||||
, hashable
|
||||
, memory
|
||||
, mtl
|
||||
, regex-base
|
||||
, regex-tdfa-text
|
||||
, text
|
||||
, unix
|
||||
, unordered-containers
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite format-tests
|
||||
ghc-options: -rtsopts -fprof-auto
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Driver.hs
|
||||
other-modules:
|
||||
NarFormat
|
||||
hs-source-dirs:
|
||||
tests
|
||||
build-depends:
|
||||
hnix-store-core
|
||||
, base
|
||||
, base64-bytestring
|
||||
, binary
|
||||
, bytestring
|
||||
, containers
|
||||
, directory
|
||||
, process
|
||||
, tasty
|
||||
, tasty-discover
|
||||
, tasty-hspec
|
||||
, tasty-hunit
|
||||
, tasty-quickcheck
|
||||
, text
|
||||
default-language: Haskell2010
|
||||
|
@ -1,181 +1,267 @@
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# 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 where
|
||||
module System.Nix.Nar (
|
||||
FileSystemObject(..)
|
||||
, IsExecutable (..)
|
||||
, Nar(..)
|
||||
, getNar
|
||||
, localPackNar
|
||||
, localUnpackNar
|
||||
, narEffectsIO
|
||||
, putNar
|
||||
) where
|
||||
|
||||
import Control.Monad (replicateM, replicateM_)
|
||||
import Data.Monoid ((<>))
|
||||
import Control.Applicative
|
||||
import qualified Data.ByteString.Lazy.Char8 as BSL
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Binary as B
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified Data.Binary.Put as B
|
||||
import qualified Data.Binary.Get as B
|
||||
import Debug.Trace
|
||||
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)
|
||||
|
||||
import System.Nix.Path
|
||||
import System.Nix.Path
|
||||
|
||||
|
||||
data NarEffects (m :: * -> *) = NarEffets {
|
||||
readFile :: FilePath -> m BSL.ByteString
|
||||
, listDir :: FilePath -> m [FileSystemObject]
|
||||
, narFromFileBytes :: BSL.ByteString -> m Nar
|
||||
, narFromDirectory :: FilePath -> m Nar
|
||||
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
|
||||
|
||||
-- TODO: Should we use rootedPath, validPath rather than FilePath?
|
||||
data Nar = Nar { narFile :: FileSystemObject }
|
||||
deriving (Eq, Ord, Show)
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | A FileSystemObject (FSO) is an anonymous entity that can be NAR archived
|
||||
data FileSystemObject =
|
||||
Regular IsExecutable BSL.ByteString
|
||||
| Directory (Set.Set (PathName, FileSystemObject))
|
||||
| SymLink BSL.ByteString
|
||||
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)
|
||||
|
||||
-- TODO - is this right? How does thesis define ordering of FSOs?
|
||||
instance Ord FileSystemObject where
|
||||
compare (Regular _ c1) (Regular _ c2) = compare c1 c2
|
||||
compare (Regular _ _) _ = GT
|
||||
compare (Directory s1) (Directory s2) = compare s1 s2
|
||||
compare (Directory _) _ = GT
|
||||
compare (SymLink l1) (SymLink l2) = compare l1 l2
|
||||
|
||||
data IsExecutable = NonExecutable | Executable
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- data NarFile = NarFile
|
||||
-- { narFileIsExecutable :: IsExecutable
|
||||
-- , narFilePath :: FilePath -- TODO: Correct type?
|
||||
-- } deriving (Show)
|
||||
|
||||
data DebugPut = PutAscii | PutBinary
|
||||
instance B.Binary Nar where
|
||||
get = getNar
|
||||
put = putNar
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Serialize Nar to lazy ByteString
|
||||
putNar :: Nar -> B.Put
|
||||
putNar = putNar' PutBinary
|
||||
|
||||
putNar' :: DebugPut -> Nar -> B.Put
|
||||
putNar' dbg (Nar file) = header <>
|
||||
parens (putFile file)
|
||||
putNar (Nar file) = header <> parens (putFile file)
|
||||
where
|
||||
|
||||
str' = case dbg of
|
||||
PutAscii -> strDebug
|
||||
PutBinary -> str
|
||||
header = str "nix-archive-1"
|
||||
|
||||
header = str' "nix-archive-1"
|
||||
parens m = str' "(" <> m <> str ")"
|
||||
|
||||
putFile (Regular isExec contents) =
|
||||
str' "type" <> str' "regular"
|
||||
<> if isExec == Executable
|
||||
then str' "executable" <> str' ""
|
||||
else str' ""
|
||||
<> str' "contents" <> str' contents
|
||||
putFile (Regular isExec fSize contents) =
|
||||
strs ["type", "regular"]
|
||||
>> (if isExec == Executable
|
||||
then strs ["executable", ""]
|
||||
else return ())
|
||||
>> putContents fSize contents
|
||||
|
||||
putFile (SymLink target) =
|
||||
str' "type" <> str' "symlink" <> str' "target" <> str' target
|
||||
strs ["type", "symlink", "target", BSL.fromStrict $ E.encodeUtf8 target]
|
||||
|
||||
-- toList sorts the entries by FilePathPart before serializing
|
||||
putFile (Directory entries) =
|
||||
str' "type" <> str' "directory"
|
||||
<> foldMap putEntry entries
|
||||
strs ["type", "directory"]
|
||||
<> mapM_ putEntry (Map.toList entries)
|
||||
|
||||
putEntry (PathName name, fso) =
|
||||
str' "entry" <>
|
||||
parens (str' "name" <>
|
||||
str' (BSL.fromStrict $ E.encodeUtf8 name) <>
|
||||
str' "node" <>
|
||||
putFile fso)
|
||||
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 = trace "header " $ assertStr "nix-archive-1"
|
||||
where
|
||||
|
||||
padLen n = let r = n `mod` 8
|
||||
p = (8 - n) `mod` 8
|
||||
in trace ("padLen: " ++ show p) p
|
||||
header = assertStr "nix-archive-1"
|
||||
|
||||
str = do
|
||||
n <- fmap fromIntegral B.getInt64le
|
||||
s <- B.getLazyByteString n
|
||||
p <- B.getByteString (padLen $ fromIntegral n)
|
||||
traceShow (n,s) $ return s
|
||||
|
||||
assertStr s = trace ("Assert " ++ show s) $ do
|
||||
s' <- str
|
||||
if s == s'
|
||||
then trace ("Assert " ++ show s ++ " passed") (return s)
|
||||
else trace ("Assert " ++ show s ++ " failed") (fail "No")
|
||||
-- Fetch a FileSystemObject
|
||||
getFile = getRegularFile <|> getDirectory <|> getSymLink
|
||||
|
||||
parens m = assertStr "(" *> m <* assertStr ")"
|
||||
getRegularFile = do
|
||||
assertStr "type"
|
||||
assertStr "regular"
|
||||
mExecutable <- optional $ Executable <$ (assertStr "executable"
|
||||
>> assertStr "")
|
||||
assertStr "contents"
|
||||
(fSize, contents) <- sizedStr
|
||||
return $ Regular (fromMaybe NonExecutable mExecutable) fSize contents
|
||||
|
||||
getFile :: B.Get FileSystemObject
|
||||
getFile = trace "getFile" (getRegularFile)
|
||||
<|> trace "getDir" (getDirectory)
|
||||
<|> trace "getLink" (getSymLink)
|
||||
getDirectory = do
|
||||
assertStr "type"
|
||||
assertStr "directory"
|
||||
fs <- many getEntry
|
||||
return $ Directory (Map.fromList fs)
|
||||
|
||||
getRegularFile = trace "regular" $ do
|
||||
trace "TESTING" (assertStr "type")
|
||||
trace "HI" $ assertStr "regular"
|
||||
trace "HI AGOIN" $ assertStr "contents"
|
||||
contents <- str
|
||||
return $ Regular (maybe NonExecutable
|
||||
(const Executable) Nothing) contents
|
||||
getSymLink = do
|
||||
assertStr "type"
|
||||
assertStr "symlink"
|
||||
assertStr "target"
|
||||
fmap (SymLink . E.decodeUtf8 . BSL.toStrict) str
|
||||
|
||||
getDirectory = do
|
||||
assertStr "type"
|
||||
assertStr "directory"
|
||||
fs <- many getEntry
|
||||
return $ Directory (Set.fromList fs)
|
||||
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)
|
||||
|
||||
getSymLink = do
|
||||
assertStr "type"
|
||||
assertStr "symlink"
|
||||
assertStr "target"
|
||||
fmap SymLink str
|
||||
-- Fetch a length-prefixed, null-padded string
|
||||
str = fmap snd sizedStr
|
||||
|
||||
getEntry = do
|
||||
assertStr "entry"
|
||||
parens $ do
|
||||
assertStr "name"
|
||||
mname <- pathName . E.decodeUtf8 . BSL.toStrict <$> str
|
||||
assertStr "node"
|
||||
file <- parens getFile
|
||||
maybe (fail "Bad PathName") (return . (,file)) mname
|
||||
sizedStr = do
|
||||
n <- B.getInt64le
|
||||
s <- B.getLazyByteString n
|
||||
p <- B.getByteString . fromIntegral $ padLen n
|
||||
return (n,s)
|
||||
|
||||
str :: BSL.ByteString -> B.Put
|
||||
str t = let len = BSL.length t
|
||||
in int len <> pad t
|
||||
parens m = assertStr "(" *> m <* assertStr ")"
|
||||
|
||||
int :: Integral a => a -> B.Put
|
||||
int n = B.putInt64le $ fromIntegral n
|
||||
assertStr s = do
|
||||
s' <- str
|
||||
if s == s'
|
||||
then return s
|
||||
else fail "No"
|
||||
|
||||
pad :: BSL.ByteString -> B.Put
|
||||
pad bs =
|
||||
let padLen = BSL.length bs `div` 8
|
||||
in B.put bs >> B.put (BSL.replicate padLen '\NUL')
|
||||
|
||||
strDebug :: BSL.ByteString -> B.Put
|
||||
strDebug t = let len = BSL.length t
|
||||
in intDebug len <> padDebug t
|
||||
-- | Distance to the next multiple of 8
|
||||
padLen :: Int64 -> Int64
|
||||
padLen n = (8 - n) `mod` 8
|
||||
|
||||
intDebug :: Integral a => a -> B.Put
|
||||
intDebug a = B.put (show @Int (fromIntegral a))
|
||||
|
||||
padDebug :: BSL.ByteString -> B.Put
|
||||
padDebug bs =
|
||||
let padLen = BSL.length bs `div` 8
|
||||
in B.put bs >> B.put (BSL.replicate padLen '_')
|
||||
-- | 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
|
||||
|
||||
where
|
||||
|
||||
localUnpackFSO basePath fso = case fso of
|
||||
|
||||
Regular isExec _ bs -> do
|
||||
(narWriteFile effs) basePath bs
|
||||
p <- narGetPerms effs basePath
|
||||
(narSetPerms effs) basePath (p {executable = isExec == Executable})
|
||||
|
||||
SymLink targ -> narCreateLink effs (T.unpack targ) basePath
|
||||
|
||||
Directory contents -> do
|
||||
narCreateDir effs basePath
|
||||
forM_ (Map.toList contents) $ \(FilePathPart path', fso) ->
|
||||
localUnpackFSO (basePath </> BSC.unpack path') fso
|
||||
|
||||
|
||||
-- | 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)
|
||||
|
||||
|
||||
|
||||
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
|
||||
}
|
||||
|
||||
|
||||
isExecutable :: Functor m => NarEffects m -> FilePath -> m IsExecutable
|
||||
isExecutable effs fp =
|
||||
bool NonExecutable Executable . executable <$> narGetPerms effs fp
|
||||
|
@ -2,27 +2,32 @@
|
||||
Description : Types and effects for interacting with the Nix store.
|
||||
Maintainer : Shea Levy <shea@shealevy.com>
|
||||
-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
module System.Nix.Path
|
||||
( PathHashAlgo
|
||||
( FilePathPart(..)
|
||||
, PathHashAlgo
|
||||
, Path(..)
|
||||
, SubstitutablePathInfo(..)
|
||||
, PathName(..)
|
||||
, filePathPart
|
||||
, pathName
|
||||
) where
|
||||
|
||||
import Crypto.Hash (Digest)
|
||||
import Crypto.Hash.Truncated (Truncated)
|
||||
import Crypto.Hash.Algorithms (SHA256)
|
||||
import qualified Data.ByteArray as B
|
||||
import Data.Text (Text)
|
||||
import Text.Regex.Base.RegexLike (makeRegex, matchTest)
|
||||
import Text.Regex.TDFA.Text (Regex)
|
||||
import Data.Hashable (Hashable(..), hashPtrWithSalt)
|
||||
import Data.HashSet (HashSet)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import System.IO.Unsafe (unsafeDupablePerformIO)
|
||||
import Crypto.Hash (Digest)
|
||||
import Crypto.Hash.Algorithms (SHA256)
|
||||
import Crypto.Hash.Truncated (Truncated)
|
||||
import qualified Data.ByteArray as B
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Char8 as BSC
|
||||
import Data.Hashable (Hashable (..), hashPtrWithSalt)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.HashSet (HashSet)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import System.IO.Unsafe (unsafeDupablePerformIO)
|
||||
import Text.Regex.Base.RegexLike (makeRegex, matchTest)
|
||||
import Text.Regex.TDFA.Text (Regex)
|
||||
|
||||
-- | The name portion of a Nix path.
|
||||
--
|
||||
@ -40,7 +45,7 @@ nameRegex =
|
||||
-- | Construct a 'PathName', assuming the provided contents are valid.
|
||||
pathName :: Text -> Maybe PathName
|
||||
pathName n = case matchTest nameRegex n of
|
||||
True -> Just $ PathName n
|
||||
True -> Just $ PathName n
|
||||
False -> Nothing
|
||||
|
||||
-- | The hash algorithm used for store path hashes.
|
||||
@ -65,12 +70,23 @@ instance Hashable Path where
|
||||
-- | Information about substitutes for a 'Path'.
|
||||
data SubstitutablePathInfo = SubstitutablePathInfo
|
||||
{ -- | The .drv which led to this 'Path'.
|
||||
deriver :: !(Maybe Path)
|
||||
deriver :: !(Maybe Path)
|
||||
, -- | The references of the 'Path'
|
||||
references :: !(HashSet Path)
|
||||
references :: !(HashSet Path)
|
||||
, -- | The (likely compressed) size of the download of this 'Path'.
|
||||
downloadSize :: !Integer
|
||||
, -- | The size of the uncompressed NAR serialization of this
|
||||
-- 'Path'.
|
||||
narSize :: !Integer
|
||||
narSize :: !Integer
|
||||
}
|
||||
|
||||
-- | 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
|
||||
|
@ -1,5 +1,3 @@
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
|
||||
{-|
|
||||
Description : Types and effects for interacting with the Nix store.
|
||||
Maintainer : Shea Levy <shea@shealevy.com>
|
||||
@ -66,7 +64,6 @@ data StoreEffects rootedPath validPath m =
|
||||
derivationOutputNames :: !(validPath -> m (HashSet Text))
|
||||
, -- | Get a full 'Path' corresponding to a given 'Digest'.
|
||||
pathFromHashPart :: !(Digest PathHashAlgo -> m Path)
|
||||
, narEffects :: NarEffects m
|
||||
, -- | Add a non-nar file to the store
|
||||
addFile :: !(BS.ByteString -> m validPath)
|
||||
}
|
||||
|
1
hnix-store-core/tests/Driver.hs
Normal file
1
hnix-store-core/tests/Driver.hs
Normal file
@ -0,0 +1 @@
|
||||
{-# OPTIONS_GHC -F -pgmF tasty-discover #-}
|
356
hnix-store-core/tests/NarFormat.hs
Normal file
356
hnix-store-core/tests/NarFormat.hs
Normal file
@ -0,0 +1,356 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
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 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 Test.Tasty.Hspec
|
||||
import qualified Test.Tasty.HUnit as HU
|
||||
import Test.Tasty.QuickCheck
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
import System.Nix.Nar
|
||||
import System.Nix.Path
|
||||
|
||||
|
||||
|
||||
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
|
||||
|
||||
-- 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
|
||||
|
||||
|
||||
describe "parser-roundtrip" $ do
|
||||
it "roundtrips regular" $ do
|
||||
roundTrip (Nar sampleRegular)
|
||||
|
||||
it "roundtrips regular 2" $ do
|
||||
roundTrip (Nar sampleRegular')
|
||||
|
||||
it "roundtrips executable" $ do
|
||||
roundTrip (Nar sampleExecutable)
|
||||
|
||||
it "roundtrips symlink" $ do
|
||||
roundTrip (Nar sampleSymLink)
|
||||
|
||||
it "roundtrips directory" $ do
|
||||
roundTrip (Nar sampleDirectory)
|
||||
|
||||
|
||||
describe "matches-nix-store fixture" $ do
|
||||
it "matches regular" $ do
|
||||
encEqualsNixStore (Nar sampleRegular) sampleRegularBaseline
|
||||
|
||||
it "matches regular'" $
|
||||
encEqualsNixStore (Nar sampleRegular') sampleRegular'Baseline
|
||||
|
||||
it "matches executable" $
|
||||
encEqualsNixStore (Nar sampleExecutable) sampleExecutableBaseline
|
||||
|
||||
it "matches symlink" $
|
||||
encEqualsNixStore (Nar sampleSymLink) sampleSymLinkBaseline
|
||||
|
||||
it "matches directory" $ do
|
||||
encEqualsNixStore (Nar sampleDirectory) sampleDirectoryBaseline
|
||||
|
||||
unit_nixStoreRegular :: HU.Assertion
|
||||
unit_nixStoreRegular = filesystemNixStore "regular" (Nar sampleRegular)
|
||||
|
||||
unit_nixStoreDirectory :: HU.Assertion
|
||||
unit_nixStoreDirectory = filesystemNixStore "directory" (Nar sampleDirectory)
|
||||
|
||||
unit_nixStoreDirectory' :: HU.Assertion
|
||||
unit_nixStoreDirectory' = filesystemNixStore "directory'" (Nar sampleDirectory')
|
||||
|
||||
unit_nixStoreBigFile :: HU.Assertion
|
||||
unit_nixStoreBigFile = getBigFileSize >>= \sz ->
|
||||
filesystemNixStore "bigfile'" (Nar $ sampleLargeFile sz)
|
||||
|
||||
unit_nixStoreBigDir :: HU.Assertion
|
||||
unit_nixStoreBigDir = getBigFileSize >>= \sz ->
|
||||
filesystemNixStore "bigfile'" (Nar $ sampleLargeDir sz)
|
||||
|
||||
prop_narEncodingArbitrary :: Nar -> Property
|
||||
prop_narEncodingArbitrary n = runGet getNar (runPut $ putNar n) === n
|
||||
|
||||
unit_packSelfSrcDir :: HU.Assertion
|
||||
unit_packSelfSrcDir = do
|
||||
ver <- try (P.readProcess "nix-store" ["--version"] "")
|
||||
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
|
||||
|
||||
unit_streamLargeFileToNar :: HU.Assertion
|
||||
unit_streamLargeFileToNar =
|
||||
bracket (getBigFileSize >>= makeBigFile) (const rmFiles) $ \_ -> do
|
||||
nar <- localPackNar narEffectsIO bigFileName
|
||||
BSL.writeFile narFileName . runPut . put $ nar
|
||||
assertBoundedMemory
|
||||
where
|
||||
bigFileName = "bigFile.bin"
|
||||
narFileName = "bigFile.nar"
|
||||
makeBigFile = \sz -> BSL.writeFile bigFileName
|
||||
(BSL.take sz $ BSL.cycle "Lorem ipsum")
|
||||
rmFiles = removeFile bigFileName >> removeFile narFileName
|
||||
|
||||
|
||||
-- **************** Utilities ************************
|
||||
|
||||
-- | Generate the ground-truth encoding on the fly with
|
||||
-- `nix-store --dump`, rather than generating fixtures
|
||||
-- beforehand
|
||||
filesystemNixStore :: String -> Nar -> IO ()
|
||||
filesystemNixStore testErrorName n = do
|
||||
|
||||
ver <- try (P.readProcess "nix-store" ["--version"] "")
|
||||
case ver of
|
||||
-- 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
|
||||
|
||||
-- stream nar contents to unpacked file(s)
|
||||
localUnpackNar narEffectsIO "testfile" n
|
||||
|
||||
-- nix-store converts those files to nar
|
||||
getNixStoreDump "testfile" >>= BSL.writeFile "nixstorenar.nar"
|
||||
|
||||
-- hnix converts those files to nar
|
||||
localPackNar narEffectsIO "testfile" >>= BSL.writeFile "hnix.nar" . runPut . putNar
|
||||
|
||||
diffResult <- P.readProcess "diff" ["nixstorenar.nar", "hnix.nar"] ""
|
||||
|
||||
assertBoundedMemory
|
||||
HU.assertEqual testErrorName diffResult ""
|
||||
|
||||
|
||||
-- | Assert that GHC uses less than 100M memory at peak
|
||||
assertBoundedMemory :: IO ()
|
||||
assertBoundedMemory = do
|
||||
bytes <- max_live_bytes <$> getRTSStats
|
||||
bytes < 100 * 1000 * 1000 `shouldBe` True
|
||||
|
||||
|
||||
-- | Read the binary output of `nix-store --dump` for a filepath
|
||||
getNixStoreDump :: String -> IO BSL.ByteString
|
||||
getNixStoreDump fp = do
|
||||
(_,Just h, _, _) <- P.createProcess
|
||||
(P.proc "nix-store" ["--dump", fp])
|
||||
{P.std_out = P.CreatePipe}
|
||||
BSL.hGetContents h
|
||||
|
||||
|
||||
-- * Several sample FSOs defined in Haskell, for use in encoding/decoding
|
||||
|
||||
-- | Simple regular text file with contents 'hi'
|
||||
sampleRegular :: FileSystemObject
|
||||
sampleRegular = Regular NonExecutable 3 "hi\n"
|
||||
|
||||
-- | Simple text file with some c code
|
||||
sampleRegular' :: FileSystemObject
|
||||
sampleRegular' = Regular 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
|
||||
where str = "#!/bin/bash\n\ngcc -o hello hello.c\n"
|
||||
|
||||
-- | A simple symlink
|
||||
sampleSymLink :: FileSystemObject
|
||||
sampleSymLink = SymLink "hello.c"
|
||||
|
||||
|
||||
-- | A directory that includes some of the above sample files
|
||||
sampleDirectory :: FileSystemObject
|
||||
sampleDirectory = Directory $ Map.fromList
|
||||
[(FilePathPart "hello.c", sampleRegular')
|
||||
,(FilePathPart "build.sh", sampleExecutable)
|
||||
,(FilePathPart "hi.c", sampleSymLink)
|
||||
]
|
||||
|
||||
-- | A deeper directory tree with crossing links
|
||||
sampleDirectory' :: FileSystemObject
|
||||
sampleDirectory' = Directory $ Map.fromList [
|
||||
|
||||
(FilePathPart "foo", Directory $ Map.fromList [
|
||||
(FilePathPart "foo.txt", Regular NonExecutable 8 "foo text")
|
||||
, (FilePathPart "tobar" , SymLink "../bar/bar.txt")
|
||||
])
|
||||
|
||||
, (FilePathPart "bar", Directory $ Map.fromList [
|
||||
(FilePathPart "bar.txt", Regular 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 "))
|
||||
|
||||
|
||||
sampleLargeFile' :: Int64 -> FileSystemObject
|
||||
sampleLargeFile' fSize =
|
||||
Regular NonExecutable fSize (BSL.take fSize (BSL.cycle "Lorems ipsums "))
|
||||
|
||||
sampleLargeDir :: Int64 -> FileSystemObject
|
||||
sampleLargeDir fSize = Directory $ Map.fromList $ [
|
||||
(FilePathPart "bf1", sampleLargeFile fSize)
|
||||
, (FilePathPart "bf2", sampleLargeFile' fSize)
|
||||
]
|
||||
++ [ (FilePathPart (BSC.pack $ 'f' : show n),
|
||||
Regular 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 ")))
|
||||
| n <- [1..100]]
|
||||
)
|
||||
]
|
||||
|
||||
-- * 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`
|
||||
|
||||
-- "hi" file turned to a NAR with `nix-store --dump`, Base64 encoded
|
||||
sampleRegularBaseline :: BSL.ByteString
|
||||
sampleRegularBaseline = B64.decodeLenient
|
||||
"DQAAAAAAAABuaXgtYXJjaGl2ZS0xAAAAAQAAAAAAAAAoAAAAAAA\
|
||||
\AAAQAAAAAAAAAdHlwZQAAAAAHAAAAAAAAAHJlZ3VsYXIACAAAAA\
|
||||
\AAAABjb250ZW50cwMAAAAAAAAAaGkKAAAAAAABAAAAAAAAACkAA\
|
||||
\AAAAAAA"
|
||||
|
||||
sampleRegular'Baseline :: BSL.ByteString
|
||||
sampleRegular'Baseline = B64.decodeLenient
|
||||
"DQAAAAAAAABuaXgtYXJjaGl2ZS0xAAAAAQAAAAAAAAAoAAAAAAA\
|
||||
\AAAQAAAAAAAAAdHlwZQAAAAAHAAAAAAAAAHJlZ3VsYXIACAAAAA\
|
||||
\AAAABjb250ZW50c0AAAAAAAAAAI2luY2x1ZGUgPHN0ZGlvLmg+C\
|
||||
\gppbnQgbWFpbihpbnQgYXJnYywgY2hhciAqYXJndltdKXsgZXhp\
|
||||
\dCAwOyB9CgEAAAAAAAAAKQAAAAAAAAA="
|
||||
|
||||
sampleExecutableBaseline :: BSL.ByteString
|
||||
sampleExecutableBaseline = B64.decodeLenient
|
||||
"DQAAAAAAAABuaXgtYXJjaGl2ZS0xAAAAAQAAAAAAAAAoAAAAAAA\
|
||||
\AAAQAAAAAAAAAdHlwZQAAAAAHAAAAAAAAAHJlZ3VsYXIACgAAAA\
|
||||
\AAAABleGVjdXRhYmxlAAAAAAAAAAAAAAAAAAAIAAAAAAAAAGNvb\
|
||||
\nRlbnRzIgAAAAAAAAAjIS9iaW4vYmFzaAoKZ2NjIC1vIGhlbGxv\
|
||||
\IGhlbGxvLmMKAAAAAAAAAQAAAAAAAAApAAAAAAAAAA=="
|
||||
|
||||
sampleSymLinkBaseline :: BSL.ByteString
|
||||
sampleSymLinkBaseline = B64.decodeLenient
|
||||
"DQAAAAAAAABuaXgtYXJjaGl2ZS0xAAAAAQAAAAAAAAAoAAAAAAA\
|
||||
\AAAQAAAAAAAAAdHlwZQAAAAAHAAAAAAAAAHN5bWxpbmsABgAAAA\
|
||||
\AAAAB0YXJnZXQAAAcAAAAAAAAAaGVsbG8uYwABAAAAAAAAACkAA\
|
||||
\AAAAAAA"
|
||||
|
||||
sampleDirectoryBaseline :: BSL.ByteString
|
||||
sampleDirectoryBaseline = B64.decodeLenient
|
||||
"DQAAAAAAAABuaXgtYXJjaGl2ZS0xAAAAAQAAAAAAAAAoAAAAAAA\
|
||||
\AAAQAAAAAAAAAdHlwZQAAAAAJAAAAAAAAAGRpcmVjdG9yeQAAAA\
|
||||
\AAAAAFAAAAAAAAAGVudHJ5AAAAAQAAAAAAAAAoAAAAAAAAAAQAA\
|
||||
\AAAAAAAbmFtZQAAAAAIAAAAAAAAAGJ1aWxkLnNoBAAAAAAAAABu\
|
||||
\b2RlAAAAAAEAAAAAAAAAKAAAAAAAAAAEAAAAAAAAAHR5cGUAAAA\
|
||||
\ABwAAAAAAAAByZWd1bGFyAAoAAAAAAAAAZXhlY3V0YWJsZQAAAA\
|
||||
\AAAAAAAAAAAAAACAAAAAAAAABjb250ZW50cyIAAAAAAAAAIyEvY\
|
||||
\mluL2Jhc2gKCmdjYyAtbyBoZWxsbyBoZWxsby5jCgAAAAAAAAEA\
|
||||
\AAAAAAAAKQAAAAAAAAABAAAAAAAAACkAAAAAAAAABQAAAAAAAAB\
|
||||
\lbnRyeQAAAAEAAAAAAAAAKAAAAAAAAAAEAAAAAAAAAG5hbWUAAA\
|
||||
\AABwAAAAAAAABoZWxsby5jAAQAAAAAAAAAbm9kZQAAAAABAAAAA\
|
||||
\AAAACgAAAAAAAAABAAAAAAAAAB0eXBlAAAAAAcAAAAAAAAAcmVn\
|
||||
\dWxhcgAIAAAAAAAAAGNvbnRlbnRzQAAAAAAAAAAjaW5jbHVkZSA\
|
||||
\8c3RkaW8uaD4KCmludCBtYWluKGludCBhcmdjLCBjaGFyICphcm\
|
||||
\d2W10peyBleGl0IDA7IH0KAQAAAAAAAAApAAAAAAAAAAEAAAAAA\
|
||||
\AAAKQAAAAAAAAAFAAAAAAAAAGVudHJ5AAAAAQAAAAAAAAAoAAAA\
|
||||
\AAAAAAQAAAAAAAAAbmFtZQAAAAAEAAAAAAAAAGhpLmMAAAAABAA\
|
||||
\AAAAAAABub2RlAAAAAAEAAAAAAAAAKAAAAAAAAAAEAAAAAAAAAH\
|
||||
\R5cGUAAAAABwAAAAAAAABzeW1saW5rAAYAAAAAAAAAdGFyZ2V0A\
|
||||
\AAHAAAAAAAAAGhlbGxvLmMAAQAAAAAAAAApAAAAAAAAAAEAAAAA\
|
||||
\AAAAKQAAAAAAAAABAAAAAAAAACkAAAAAAAAA"
|
||||
|
||||
|
||||
-- | Control testcase sizes (bytes) by env variable
|
||||
getBigFileSize :: IO Int64
|
||||
getBigFileSize = fromMaybe 1000000 . readMaybe <$> (getEnv "HNIX_BIG_FILE_SIZE" <|> pure "")
|
||||
|
||||
|
||||
-- | Add a link to a FileSystemObject. This is useful
|
||||
-- when creating Arbitrary FileSystemObjects. It
|
||||
-- isn't implemented yet
|
||||
mkLink ::
|
||||
FilePath -- ^ Target
|
||||
-> FilePath -- ^ Link
|
||||
-> FileSystemObject -- ^ FileSystemObject to add link to
|
||||
-> FileSystemObject
|
||||
mkLink = undefined -- TODO
|
||||
|
||||
|
||||
instance Arbitrary Nar where
|
||||
arbitrary = Nar <$> resize 10 arbitrary
|
||||
|
||||
instance Arbitrary FileSystemObject where
|
||||
-- To build an arbitrary Nar,
|
||||
arbitrary = do
|
||||
n <- getSize
|
||||
if n < 2
|
||||
then arbFile
|
||||
else arbDirectory n
|
||||
|
||||
where
|
||||
|
||||
arbFile :: Gen FileSystemObject
|
||||
arbFile = do
|
||||
Positive fSize <- arbitrary
|
||||
Regular
|
||||
<$> elements [NonExecutable, Executable]
|
||||
<*> pure (fromIntegral fSize)
|
||||
<*> oneof [
|
||||
fmap (BSL.take fSize . BSL.cycle . BSL.pack . getNonEmpty) arbitrary , -- Binary File
|
||||
fmap (BSL.take fSize . BSL.cycle . BSLC.pack . getNonEmpty) arbitrary -- ASCII File
|
||||
]
|
||||
|
||||
arbName :: Gen FilePathPart
|
||||
arbName = fmap (FilePathPart . BS.pack . fmap (fromIntegral . fromEnum)) $ do
|
||||
Positive n <- arbitrary
|
||||
replicateM n (elements $ ['a'..'z'] ++ ['0'..'9'])
|
||||
|
||||
arbDirectory :: Int -> Gen FileSystemObject
|
||||
arbDirectory n = fmap (Directory . Map.fromList) $ replicateM n $ do
|
||||
nm <- arbName
|
||||
f <- oneof [arbFile, arbDirectory (n `div` 2)]
|
||||
return (nm,f)
|
Loading…
Reference in New Issue
Block a user