haskell-nix/hnix-store
1
1
Fork 0
mirror of https://github.com/haskell-nix/hnix-store.git synced 2024-09-11 18:05:56 +03:00
Code Issues Projects Releases Wiki Activity

Use constant-space encoding and decoding for NARs

Browse Source
This commit is contained in:
Greg Hale 2020-03-22 14:06:16 -04:00
parent 59e08d49ef
commit 3de47a36e7
8 changed files with 1174 additions and 332 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
default.nix
View File

@ -1,5 +1,5 @@
{ pkgs ? import <nixpkgs> {} }: let
overlay = import ./overlay.nix;
overlay = import ./overlay.nix pkgs.haskell.lib;
overrideHaskellPackages = orig: {
buildHaskellPackages =
orig.buildHaskellPackages.override overrideHaskellPackages;

13
hnix-store-core/hnix-store-core.cabal
View File

@ -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
@ -23,6 +23,9 @@ library
, 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
@ -32,10 +35,12 @@ library
, System.Nix.StorePathMetadata
build-depends: base >=4.10 && <5
, attoparsec
, algebraic-graphs >= 0.5 && < 0.6
, base16-bytestring
, bytestring
, binary
, bytestring
, cereal
, containers
, cryptohash-md5
, cryptohash-sha1
@ -43,6 +48,8 @@ library
, directory
, filepath
, hashable
, lifted-base
, monad-control
, mtl
, nix-derivation >= 1.1.1 && <2
, saltine
@ -83,7 +90,10 @@ test-suite format-tests
, containers
, filepath
, directory
, filepath
, io-streams
, process
, process-extras
, tasty
, tasty-discover
, tasty-golden
@ -92,4 +102,5 @@ test-suite format-tests
, tasty-quickcheck
, temporary
, text
, unix
default-language: Haskell2010

95
hnix-store-core/src/System/Nix/Internal/Nar/Effects.hs Normal file
View File

@ -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

468
hnix-store-core/src/System/Nix/Internal/Nar/Parser.hs Normal file
View File

@ -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)

104
hnix-store-core/src/System/Nix/Internal/Nar/Streamer.hs Normal file
View File

@ -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

326
hnix-store-core/src/System/Nix/Nar.hs
View File

@ -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 #-}
{-# LANGUAGE TypeFamilies #-}
{-|
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
-- * Encoding and Decoding NAR archives
buildNarIO
, unpackNarIO
-- * Experimental
, Nar.parseNar
, Nar.testParser
, Nar.testParser'
-- * Filesystem capabilities used by NAR encoder/decoder
, Nar.NarEffects(..)
, Nar.narEffectsIO
-- * Internal
, Nar.streamNarIO
, Nar.runParser
) 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)
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
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
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
-- For a description of the NAR format, see Eelco's 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)
-- | 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
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"
-- | Distance to the next multiple of 8
padLen :: Int64 -> Int64
padLen n = (8 - n) `mod` 8
-- | 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
-- | 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

496
hnix-store-core/tests/NarFormat.hs
View File

@ -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 (doesDirectoryExist, 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 @@ spec_narEncoding = do
it "matches directory" $ do
encEqualsNixStore (Nar sampleDirectory) sampleDirectoryBaseline
unit_nixStoreRegular :: HU.Assertion
unit_nixStoreRegular = filesystemNixStore "regular" (Nar sampleRegular)
@ -89,20 +139,29 @@ 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)
test_nixStoreBigFile :: TestTree
test_nixStoreBigFile = packThenExtract "bigfile" $ \baseDir -> do
mkBigFile (baseDir </> "bigfile")
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 </> "")
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
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
@ -111,29 +170,108 @@ unit_packSelfSrcDir = do
case srcHere of
False -> return ()
True -> do
hnixNar <- runPut . put <$> localPackNar narEffectsIO dir
nixStoreNar <- getNixStoreDump dir
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
@ -147,19 +285,33 @@ filesystemNixStore testErrorName n = do
-- 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 ""
@ -176,6 +328,60 @@ assertBoundedMemory = do
#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
@ -189,17 +395,17 @@ getNixStoreDump fp = do
-- | 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
@ -220,24 +426,24 @@ sampleDirectory' :: FileSystemObject
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 $ [
@ -245,16 +451,25 @@ sampleLargeDir fSize = Directory $ Map.fromList $ [
, (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`
@ -322,7 +537,7 @@ sampleDirectoryBaseline = B64.decodeLenient $ BSL.concat
-- | 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
@ -335,6 +550,36 @@ mkLink ::
-> 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
@ -353,7 +598,7 @@ instance Arbitrary FileSystemObject where
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
@ -370,3 +615,120 @@ instance Arbitrary FileSystemObject where
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"

2
overlay.nix
View File

@ -1,4 +1,4 @@
huper: helf: {
hlib: helf: huper: {
hnix-store-core =
helf.callCabal2nix "hnix-store-core" ./hnix-store-core {};
hnix-store-remote =