diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,9 @@ +# 0.1.0.0 2024-07-31 + +* Initial release after a split from `hnix-store-core` + +--- + +`hnix-store-nar` uses [PVP Versioning][1]. + +[1]: https://pvp.haskell.org diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright 2018 Shea Levy. + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,8 @@ +# hnix-store-nar + +`NAR` file format packing and unpacking. + +For a description of the NAR format, see [`Eelco's thesis`](https://nixos.org/~eelco/pubs/phd-thesis.pdf). + +[System.Nix.Nar]: ./src/System/Nix/Nar.hs +[System.Nix.Nar.Effects]: ./src/System/Nix/Nar/Effects.hs diff --git a/hnix-store-nar.cabal b/hnix-store-nar.cabal new file mode 100644 --- /dev/null +++ b/hnix-store-nar.cabal @@ -0,0 +1,117 @@ +cabal-version: 2.2 +name: hnix-store-nar +version: 0.1.0.0 +synopsis: NAR file format +description: + Packing and unpacking for NAR file format used by Nix. +homepage: https://github.com/haskell-nix/hnix-store +license: Apache-2.0 +license-file: LICENSE +author: Shea Levy +maintainer: srk@48.io +copyright: 2018 Shea Levy +category: Nix +build-type: Simple +extra-doc-files: + CHANGELOG.md +extra-source-files: + README.md + , tests/fixtures/case-conflict.nar + +flag bounded_memory + description: Run tests of constant memory use (requires +RTS -T) + default: False + manual: True + +common commons + ghc-options: -Wall + default-extensions: + ConstraintKinds + , DataKinds + , DeriveGeneric + , DeriveDataTypeable + , DeriveFunctor + , DeriveFoldable + , DeriveTraversable + , DeriveLift + , DerivingStrategies + , DerivingVia + , ExistentialQuantification + , FlexibleContexts + , FlexibleInstances + , GADTs + , StandaloneDeriving + , ScopedTypeVariables + , StandaloneDeriving + , RecordWildCards + , TypeApplications + , TypeFamilies + , TypeOperators + , TypeSynonymInstances + , InstanceSigs + , KindSignatures + , MultiParamTypeClasses + , MultiWayIf + , TupleSections + , LambdaCase + , BangPatterns + , ViewPatterns + default-language: Haskell2010 + +library + import: commons + exposed-modules: + System.Nix.Nar + , System.Nix.Nar.Parser + , System.Nix.Nar.Streamer + , System.Nix.Nar.Effects + , System.Nix.Nar.Options + build-depends: + base >=4.12 && <5 + , algebraic-graphs >= 0.5 && < 0.8 + , bytestring + , case-insensitive + , cereal + , containers + , directory + , filepath + , lifted-base + , monad-control + , mtl + , text + , unix + , unordered-containers + hs-source-dirs: src + +test-suite nar + import: commons + if flag(bounded_memory) + cpp-options: -DBOUNDED_MEMORY + ghc-options: -rtsopts -fprof-auto "-with-rtsopts -T" + type: exitcode-stdio-1.0 + main-is: Driver.hs + other-modules: + NarFormat + hs-source-dirs: + tests + build-tool-depends: + tasty-discover:tasty-discover + build-depends: + base + , cryptonite + , hnix-store-nar + , base64-bytestring + , cereal + , bytestring + , containers + , directory + , filepath + , hspec + , process + , temporary + , tasty + , tasty-hspec + , tasty-hunit + , tasty-quickcheck + , text + , unix diff --git a/src/System/Nix/Nar.hs b/src/System/Nix/Nar.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Nar.hs @@ -0,0 +1,69 @@ +{- +Description : Generating and consuming NAR files +Maintainer : Shea Levy +-} + +module System.Nix.Nar + ( + -- * 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 + + , Nar.NarOptions(..) + , Nar.defaultNarOptions + + -- * Internal + , Nar.streamNarIO + , Nar.streamNarIOWithOptions + , Nar.runParser + , Nar.runParserWithOptions + , Nar.dumpString + , Nar.dumpPath + + -- * Type + , Nar.NarSource + ) where + +import qualified Control.Concurrent as Concurrent +import qualified Data.ByteString as BS +import qualified System.IO as IO + +import qualified System.Nix.Nar.Effects as Nar +import qualified System.Nix.Nar.Options as Nar +import qualified System.Nix.Nar.Parser as Nar +import qualified System.Nix.Nar.Streamer as Nar + +-- For a description of the NAR format, see Eelco's thesis +-- https://nixos.org/~eelco/pubs/phd-thesis.pdf + +-- | Pack the filesystem object at @FilePath@ into a NAR and stream it into the +-- @IO.Handle@ +-- The handle should aleady be open and in @WriteMode@. +buildNarIO + :: Nar.NarEffects IO + -> FilePath + -> IO.Handle + -> IO () +buildNarIO effs basePath outHandle = + Nar.streamNarIO + effs + basePath + (\chunk -> BS.hPut outHandle chunk >> Concurrent.threadDelay 10) + +-- | 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 = Nar.runParser effs Nar.parseNar diff --git a/src/System/Nix/Nar/Effects.hs b/src/System/Nix/Nar/Effects.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Nar/Effects.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE RankNTypes #-} + +module System.Nix.Nar.Effects + ( NarEffects(..) + , narEffectsIO + , IsExecutable(..) + , isExecutable + , setExecutable + ) where + +import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Data.ByteString (ByteString) +import Data.Bool (bool) +import Data.Int (Int64) +import Data.Kind (Type) +import System.IO (Handle, IOMode(WriteMode)) + +import qualified Control.Monad +import qualified Data.ByteString +import qualified Data.ByteString.Lazy as Bytes.Lazy +import qualified System.Directory as Directory +import System.Posix.Files ( createSymbolicLink + , fileMode + , fileSize + , FileStatus + , getFileStatus + , getSymbolicLinkStatus + , groupExecuteMode + , intersectFileModes + , isDirectory + , isRegularFile + , nullFileMode + , otherExecuteMode + , ownerExecuteMode + , readSymbolicLink + , setFileMode + , unionFileModes + ) +import qualified System.IO as IO +import qualified Control.Exception.Lifted as Exception.Lifted + +data IsExecutable = NonExecutable | Executable + deriving (Eq, Show) + +data NarEffects (m :: Type -> Type) = NarEffects { + narReadFile :: FilePath -> m Bytes.Lazy.ByteString + , narWriteFile :: FilePath -> IsExecutable -> Bytes.Lazy.ByteString -> m () + , narStreamFile :: FilePath -> IsExecutable -> m (Maybe ByteString) -> m () + , narListDir :: FilePath -> m [FilePath] + , narCreateDir :: FilePath -> m () + , narCreateLink :: FilePath -> FilePath -> m () + , narIsExec :: FilePath -> m IsExecutable + , 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 + :: ( MonadIO m + , MonadFail m + , MonadBaseControl IO m + ) + => NarEffects m +narEffectsIO = NarEffects { + narReadFile = liftIO . Bytes.Lazy.readFile + , narWriteFile = \f e c -> liftIO $ do + Bytes.Lazy.writeFile f c + Control.Monad.when (e == Executable) $ + setExecutable f + , narStreamFile = streamStringOutIO + , narListDir = liftIO . Directory.listDirectory + , narCreateDir = liftIO . Directory.createDirectory + , narCreateLink = \f -> liftIO . createSymbolicLink f + , narIsExec = liftIO . fmap (bool NonExecutable Executable . isExecutable) . getSymbolicLinkStatus + , narIsDir = fmap isDirectory . liftIO . getFileStatus + , narIsSymLink = liftIO . Directory.pathIsSymbolicLink + , narFileSize = fmap (fromIntegral . fileSize) . liftIO . getFileStatus + , narReadLink = liftIO . readSymbolicLink + , narDeleteDir = liftIO . Directory.removeDirectoryRecursive + , narDeleteFile = liftIO . Directory.removeFile + } + +-- | This default implementation for @narStreamFile@ requires @MonadIO@ +streamStringOutIO + :: forall m + . ( MonadIO m + , MonadFail m + , MonadBaseControl IO m + ) + => FilePath + -> IsExecutable + -> m (Maybe ByteString) + -> m () +streamStringOutIO f executable getChunk = + Exception.Lifted.bracket + (liftIO $ IO.openFile f WriteMode) + (\h -> liftIO (updateExecutablePermissions >> IO.hClose h)) + go + `Exception.Lifted.catch` + cleanupException + where + go :: Handle -> m () + go handle = do + chunk <- getChunk + case chunk of + Nothing -> pure () + Just c -> do + liftIO $ Data.ByteString.hPut handle c + go handle + updateExecutablePermissions = + Control.Monad.when (executable == Executable) $ + setExecutable f + cleanupException (e :: Exception.Lifted.SomeException) = do + liftIO $ Directory.removeFile f + Control.Monad.fail $ + "Failed to stream string to " <> f <> ": " <> show e + +-- | Check whether the file is executable by the owner. +-- +-- Matches the logic used by Nix. +-- +-- access() should not be used for this purpose on macOS. +-- It returns false for executables when placed in certain directories. +-- For example, when in an app bundle: App.app/Contents/Resources/en.lproj/myexecutable.strings +isExecutable :: FileStatus -> Bool +isExecutable st = + isRegularFile st + && fileMode st `intersectFileModes` ownerExecuteMode /= nullFileMode + +-- | Set the file to be executable by the owner, group, and others. +-- +-- Matches the logic used by Nix. +setExecutable :: FilePath -> IO () +setExecutable f = do + st <- getSymbolicLinkStatus f + let p = + fileMode st + `unionFileModes` ownerExecuteMode + `unionFileModes` groupExecuteMode + `unionFileModes` otherExecuteMode + setFileMode f p diff --git a/src/System/Nix/Nar/Options.hs b/src/System/Nix/Nar/Options.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Nar/Options.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} +module System.Nix.Nar.Options + ( NarOptions(..) + , defaultNarOptions + , caseHackSuffix + ) where + +import Data.Text (Text) +import qualified System.Info + +-- | Options for configuring how NAR files are encoded and decoded. +data NarOptions = NarOptions { + optUseCaseHack :: Bool + -- ^ Whether to enable a case hack to support case-insensitive filesystems. + -- Equivalent to the 'use-case-hack' option in the Nix client. + -- + -- The case hack rewrites file names to avoid collisions on case-insensitive file systems, e.g. APFS and HFS+ on macOS. + -- Enabled by default on macOS (Darwin). +} + +defaultNarOptions :: NarOptions +defaultNarOptions = NarOptions { + optUseCaseHack = + if System.Info.os == "darwin" + then True + else False +} + +caseHackSuffix :: Text +caseHackSuffix = "~nix~case~hack~" diff --git a/src/System/Nix/Nar/Parser.hs b/src/System/Nix/Nar/Parser.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Nar/Parser.hs @@ -0,0 +1,541 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +-- | A streaming parser for the NAR format + +module System.Nix.Nar.Parser + ( runParser + , runParserWithOptions + , parseNar + , testParser + , testParser' + ) 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 Exception.Lifted +import Control.Monad ( forM + , when + , forM_ + ) +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 Data.ByteString (ByteString) +import qualified Data.ByteString as Bytes +import Data.Bool ( bool ) +import qualified Data.Either as Either +import Data.Int ( Int64 ) +import qualified Data.IORef as IORef +import qualified Data.CaseInsensitive as CI +import qualified Data.HashMap.Strict as HashMap +import qualified Data.List as List +import qualified Data.Map as Map +import Data.Maybe ( catMaybes ) +import qualified Data.Serialize as Serialize +import Data.Text ( Text ) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified System.Directory as Directory +import System.FilePath as FilePath +import qualified System.IO as IO + +import qualified System.Nix.Nar.Effects as Nar +import qualified System.Nix.Nar.Options 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 (ParserEnv m) m) + ) + a + } + deriving ( Functor, Applicative, Monad, Fail.MonadFail + , Trans.MonadIO, State.MonadState ParserState + , Except.MonadError String + , Reader.MonadReader (ParserEnv m) + ) + +data ParserEnv m = ParserEnv + { envNarEffects :: Nar.NarEffects m + , envNarOptions :: Nar.NarOptions + } + +getNarEffects :: Monad m => NarParser m (Nar.NarEffects m) +getNarEffects = fmap envNarEffects Reader.ask + +getNarEffect :: Monad m => (Nar.NarEffects m -> a) -> NarParser m a +getNarEffect eff = fmap eff getNarEffects + +getNarOptions :: Monad m => NarParser m Nar.NarOptions +getNarOptions = fmap envNarOptions Reader.ask + +-- | 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 @ReadMode@ + -> FilePath + -- ^ The root file system object to be created by the NAR + -> m (Either String a) +runParser effs parser h target = do + runParserWithOptions Nar.defaultNarOptions effs parser h target + +runParserWithOptions + :: forall m a + . (IO.MonadIO m, Base.MonadBaseControl IO m) + => Nar.NarOptions + -> 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 @ReadMode@ + -> FilePath + -- ^ The root file system object to be created by the NAR + -> m (Either String a) +runParserWithOptions opts effs (NarParser action) h target = do + unpackResult <- + Reader.runReaderT (Except.runExceptT $ State.evalStateT action state0) (ParserEnv effs opts) + `Exception.Lifted.catch` exceptionHandler + when (Either.isLeft unpackResult) cleanup + pure unpackResult + + where + state0 :: ParserState + state0 = + ParserState + { tokenStack = [] + , handle = h + , directoryStack = [target] + , links = [] + , filePaths = HashMap.empty + } + + exceptionHandler :: Exception.Lifted.SomeException -> m (Either String a) + exceptionHandler e = + pure $ Left $ "Exception while unpacking NAR file: " <> show e + + cleanup :: m () + cleanup = + (\ef trg -> do + isDir <- Nar.narIsDir ef trg + bool + (Nar.narDeleteFile ef trg) + (Nar.narDeleteDir ef trg) + isDir + ) effs target + +instance Trans.MonadTrans NarParser where + lift act = NarParser $ (Trans.lift . Trans.lift . Trans.lift) act + +data ParserState = ParserState + { tokenStack :: ![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 + , filePaths :: HashMap.HashMap (CI.CI FilePath) Int + -- ^ A map of case-insensitive files paths to the number of collisions encountered. + -- See @Nar.NarOptions.optUseCaseHack@ for details. + } + +------------------------------------------------------------------------------ +-- * 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 pure @()@ +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 = Text.unpack target + , linkFile = file + , linkPWD = dir + } + where + currentDirectoryAndFile :: Monad m => NarParser m (FilePath, FilePath) + currentDirectoryAndFile = do + dirStack <- State.gets directoryStack + case dirStack of + (x:xs) -> pure (List.foldr1 () (List.reverse xs), x) + _ -> error "currentDirectoryAndFile: empty 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 :: [String] -> String) ["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 ByteString) + getChunk = do + bytesLeft <- IO.liftIO $ IORef.readIORef bytesLeftVar + if bytesLeft == 0 + then pure Nothing + else do + chunk <- IO.liftIO $ Bytes.hGetSome narHandle $ fromIntegral $ min 10000 bytesLeft + when (Bytes.null chunk) (Fail.fail "ZERO BYTES") + IO.liftIO $ IORef.modifyIORef bytesLeftVar $ \n -> n - fromIntegral (Bytes.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 + pure $ Just chunk + + target <- currentFile + streamFile <- getNarEffect Nar.narStreamFile + let isExecutable = bool Nar.NonExecutable Nar.Executable (s == "executable") + Trans.lift (streamFile target isExecutable getChunk) + + expectRawString (Bytes.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 <- getNarEffect Nar.narCreateDir + target <- currentFile + Trans.lift $ createDirectory target + parseEntryOrFinish target + + where + + parseEntryOrFinish :: (IO.MonadIO m, Fail.MonadFail m) => FilePath -> NarParser m () + parseEntryOrFinish path = + -- 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 path ) + ] + + parseEntry :: (IO.MonadIO m, Fail.MonadFail m) => FilePath -> NarParser m () + parseEntry path = do + opts <- getNarOptions + parens $ do + expectStr "name" + fName <- + if Nar.optUseCaseHack opts then + addCaseHack path =<< parseStr + else + parseStr + pushFileName (Text.unpack fName) + expectStr "node" + parens parseFSO + popFileName + parseEntryOrFinish path + + addCaseHack :: (IO.MonadIO m, Fail.MonadFail m) => FilePath -> Text -> NarParser m Text + addCaseHack path fName = do + let key = path Text.unpack fName + recordFilePath key + conflictCount <- getFilePathConflictCount key + pure $ + if conflictCount > 0 then + fName <> Nar.caseHackSuffix <> (Text.pack $ show conflictCount) + else + fName + +------------------------------------------------------------------------------ +-- * 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 Text +parseStr = do + cachedStr <- popStr + case cachedStr of + Just str -> pure str + Nothing -> do + len <- parseLength + strBytes <- consume $ fromIntegral len + expectRawString + (Bytes.replicate (fromIntegral $ padLen $ fromIntegral len) 0) + pure $ Text.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 + either + (\e -> Fail.fail $ "parseLength failed to decode int64: " <> e) + pure + (Serialize.runGet Serialize.getInt64le eightBytes) + +-- | Consume a NAR string and assert that it matches an expectation +expectStr :: (IO.MonadIO m, Fail.MonadFail m) => Text -> NarParser m () +expectStr expected = do + actual <- parseStr + when (actual /= expected) $ + Fail.fail $ "Expected " <> err expected <> ", got " <> err actual + where + err t = + show $ + bool + t + (Text.take 10 t <> "...") + (Text.length t > 10) + +-- | 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) => ByteString -> NarParser m () +expectRawString expected = do + actual <- consume $ Bytes.length expected + when (actual /= expected) + $ Fail.fail + $ "Expected " + <> err expected + <> ", got " + <> err actual + where + err bs = + show $ + bool + bs + (Bytes.take 10 bs <> "...") + (Bytes.length bs > 10) + +-- | Consume a NAR string, and dispatch to a parser depending on which string +-- matched +matchStr + :: (IO.MonadIO m, Fail.MonadFail m) + => [(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 ")" + pure 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 <- getNarEffect Nar.narCreateLink + allLinks <- State.gets links + sortedLinks <- IO.liftIO $ sortLinksIO allLinks + forM_ 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) + pure (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 + pure $ 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 ByteString +consume 0 = pure "" +consume n = do + state0 <- State.get + newBytes <- IO.liftIO $ Bytes.hGet (handle state0) (max 0 n) + when (Bytes.length newBytes < n) $ + Fail.fail $ + "consume: Not enough bytes in handle. Wanted " + <> show n <> " got " <> show (Bytes.length newBytes) + pure newBytes + +-- | Pop a string off the token stack +popStr :: Monad m => NarParser m (Maybe Text) +popStr = do + s <- State.get + case List.uncons (tokenStack s) of + Nothing -> pure Nothing + Just (x, xs) -> do + State.put $ s { tokenStack = xs } + pure $ Just x + +-- | Push a string onto the token stack +pushStr :: Monad m => Text -> NarParser m () +pushStr str = + 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 = + 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 + pure $ 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 }) + +-- | Add a file path to the collection of encountered file paths +recordFilePath :: Monad m => FilePath -> NarParser m () +recordFilePath fPath = + State.modify (\s -> s { filePaths = HashMap.insertWith (\_ v -> v + 1) (CI.mk fPath) 0 (filePaths s) }) + +getFilePathConflictCount :: Monad m => FilePath -> NarParser m Int +getFilePathConflictCount fPath = do + fileMap <- State.gets filePaths + pure $ HashMap.findWithDefault 0 (CI.mk fPath) fileMap + +------------------------------------------------------------------------------ +-- * Utilities + +testParser :: (m ~ IO) => NarParser m a -> ByteString -> m (Either String a) +testParser p b = do + Bytes.writeFile tmpFileName b + IO.withFile tmpFileName IO.ReadMode $ \h -> + runParser Nar.narEffectsIO p h tmpFileName + where + tmpFileName = "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 + +-- | Debugging helper +_dbgState :: IO.MonadIO m => NarParser m () +_dbgState = do + s <- State.get + IO.liftIO $ print (tokenStack s, directoryStack s) diff --git a/src/System/Nix/Nar/Streamer.hs b/src/System/Nix/Nar/Streamer.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Nar/Streamer.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Stream out a NAR file from a regular file + +module System.Nix.Nar.Streamer + ( NarSource + , dumpString + , dumpPath + , streamNarIO + , streamNarIOWithOptions + , Nar.IsExecutable(..) + ) where + +import Data.ByteString (ByteString) +import Data.Int (Int64) +import Data.Text (Text) + +import Control.Monad ( forM_ + , when + ) +import qualified Control.Monad.IO.Class as IO +import qualified Data.ByteString as Bytes +import qualified Data.ByteString.Lazy as Bytes.Lazy +import qualified Data.Foldable +import qualified Data.List +import qualified Data.Serialize as Serial +import qualified Data.Text as T (pack, breakOn) +import qualified Data.Text.Encoding as TE (encodeUtf8) +import System.FilePath (()) + +import qualified System.Nix.Nar.Effects as Nar +import qualified System.Nix.Nar.Options as Nar + +-- | NarSource +-- The source to provide nar to the handler `(ByteString -> m ())`. +-- It is isomorphic to ByteString by Yoneda lemma +-- if the result is meant to be m (). +-- It is done in CPS style so IO can be chunks. +type NarSource m = (ByteString -> m ()) -> m () + +-- | dumpString +-- dump a string to nar in CPS style. The function takes in a `ByteString`, +-- and build a `NarSource m`. +dumpString + :: forall m + . IO.MonadIO m + => ByteString -- ^ the string you want to dump + -> NarSource m -- ^ The nar result in CPS style +dumpString text yield = Data.Foldable.traverse_ (yield . str) + ["nix-archive-1", "(", "type" , "regular", "contents", text, ")"] + +-- | dumpPath +-- shorthand +-- build a Source that turn file path to nar using the default narEffectsIO. +dumpPath + :: forall m + . IO.MonadIO m + => FilePath -- ^ path for the file you want to dump to nar + -> NarSource m -- ^ the nar result in CPS style +dumpPath = streamNarIO Nar.narEffectsIO + +-- | 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 + => Nar.NarEffects IO + -> FilePath + -> NarSource m +streamNarIO effs basePath yield = + streamNarIOWithOptions Nar.defaultNarOptions effs basePath yield + +streamNarIOWithOptions + :: forall m + . IO.MonadIO m + => Nar.NarOptions + -> Nar.NarEffects IO + -> FilePath + -> NarSource m +streamNarIOWithOptions opts effs basePath yield = do + yield $ str "nix-archive-1" + parens $ go basePath + where + go :: FilePath -> m () + go path = do + isSymLink <- IO.liftIO $ Nar.narIsSymLink effs path + if isSymLink then do + target <- IO.liftIO $ Nar.narReadLink effs path + yield $ + strs ["type", "symlink", "target", filePathToBS target] + else do + isDir <- IO.liftIO $ Nar.narIsDir effs path + if isDir then do + fs <- IO.liftIO (Nar.narListDir effs path) + yield $ strs ["type", "directory"] + forM_ (Data.List.sort fs) $ \f -> do + yield $ str "entry" + parens $ do + let fullName = path f + let serializedPath = + if Nar.optUseCaseHack opts then + filePathToBSWithCaseHack f + else + filePathToBS f + yield $ strs ["name", serializedPath, "node"] + parens $ go fullName + else do + isExec <- IO.liftIO $ Nar.narIsExec effs path + yield $ strs ["type", "regular"] + when (isExec == Nar.Executable) $ yield $ strs ["executable", ""] + fSize <- IO.liftIO $ Nar.narFileSize effs path + yield $ str "contents" + yield $ int fSize + yieldFile path fSize + + parens act = do + yield $ str "(" + r <- act + yield $ str ")" + pure r + + -- Read, yield, and pad the file + yieldFile :: FilePath -> Int64 -> m () + yieldFile path fsize = do + mapM_ yield . Bytes.Lazy.toChunks =<< IO.liftIO (Nar.narReadFile effs path) + yield $ Bytes.replicate (padLen $ fromIntegral fsize) 0 + +-- | Distance to the next multiple of 8 +padLen :: Int -> Int +padLen n = (8 - n) `mod` 8 + +int :: Integral a => a -> ByteString +int n = Serial.runPut $ Serial.putInt64le $ fromIntegral n + +str :: ByteString -> ByteString +str t = + let + len = Bytes.length t + in + int len <> padBS len t + +padBS :: Int -> ByteString -> ByteString +padBS strSize bs = bs <> Bytes.replicate (padLen strSize) 0 + +strs :: [ByteString] -> ByteString +strs xs = Bytes.concat $ str <$> xs + +filePathToBS :: FilePath -> ByteString +filePathToBS = TE.encodeUtf8 . T.pack + +filePathToBSWithCaseHack :: FilePath -> ByteString +filePathToBSWithCaseHack = TE.encodeUtf8 . undoCaseHack . T.pack + +undoCaseHack :: Text -> Text +undoCaseHack = fst . T.breakOn Nar.caseHackSuffix diff --git a/tests/Driver.hs b/tests/Driver.hs new file mode 100644 --- /dev/null +++ b/tests/Driver.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover #-} diff --git a/tests/NarFormat.hs b/tests/NarFormat.hs new file mode 100644 --- /dev/null +++ b/tests/NarFormat.hs @@ -0,0 +1,783 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module NarFormat where + +import Control.Applicative (many, optional, (<|>)) +import qualified Control.Concurrent as Concurrent +import Control.Exception (SomeException, try) +import Control.Monad (replicateM, void, forM_, when) +import Crypto.Hash (hash, Digest, SHA256) +import Data.Serialize (Serialize(..)) +import Data.Serialize (Get, getByteString, + getInt64le, + getLazyByteString, runGet) +import Data.Serialize (Putter, putInt64le, + putByteString, runPut) +import Data.Bool (bool) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 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 ( Int64 ) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import GHC.Generics ( Generic ) +import System.Directory ( doesDirectoryExist + , doesPathExist + , 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.Temp as Temp +import qualified System.Posix.Files as Unix +import qualified System.Posix.Process as Unix +import qualified System.Process as P +import Test.Tasty as T +import Test.Hspec +import qualified Test.Tasty.HUnit as HU +import Test.Tasty.QuickCheck +import qualified Text.Printf as Printf +import Text.Read (readMaybe) + +import System.Nix.Nar.Streamer (IsExecutable(Executable, NonExecutable)) +import System.Nix.Nar + +-- Without the import, `max_live_bytes` and `getRTSStats` are undefined on some setups. +#ifdef BOUNDED_MEMORY +import GHC.Stats +#endif + + +withBytesAsHandle :: BSC.ByteString -> (IO.Handle -> IO a) -> IO a +withBytesAsHandle bytes act = do + Temp.withSystemTempFile "nar-test-file-XXXXX" $ \tmpFile h -> do + IO.hClose h + BSC.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 + 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 + BSC.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 :: Nar -> BSC.ByteString -> IO () + encEqualsNixStore n b = runPut (putNar n) `shouldBe` b + + + describe "parser-roundtrip" $ do + it "roundtrips regular" $ do + roundTrip "sampleRegular" (Nar sampleRegular) + + it "roundtrips regular 2" $ do + roundTrip "sampleRegular'" (Nar sampleRegular') + + it "roundtrips executable" $ do + roundTrip "sampleExecutable" (Nar sampleExecutable) + + it "roundtrips directory" $ do + roundTrip "sampleDirectory" (Nar sampleDirectory) + + it "roundtrips case conflicts" $ do + nar <- decodeFile "tests/fixtures/case-conflict.nar" + roundTrip "caseConflict" nar + + 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 + + it "matches symlink to directory" $ do + encEqualsNixStore (Nar sampleLinkToDirectory) sampleLinkToDirectoryBaseline + + +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') + +-- | Test that the executable permissions are handled correctly in app bundles on macOS. +-- In this case, access() returns false for a file under this specific path, even when the executable bit is set. +-- NAR implementations should avoid this syscall on macOS. +test_nixStoreMacOSAppBundle :: TestTree +test_nixStoreMacOSAppBundle = packThenExtract "App.app" $ \ baseDir -> do + let testDir = baseDir "App.app" "Resources" "en.lproj" + Directory.createDirectoryIfMissing True testDir + mkExecutableFile (testDir "test.strings") + +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 "") + + +prop_narEncodingArbitrary :: Nar -> Property +prop_narEncodingArbitrary n = runGet getNar (runPut $ putNar n) === Right n + +unit_packSelfSrcDir :: HU.Assertion +unit_packSelfSrcDir = Temp.withSystemTempDirectory "nar-test" $ \tmpDir -> do + ver <- try (P.readProcess "nix-store" ["--version"] "") + let narFilePath = tmpDir "src.nar" + case ver of + Left (_ :: SomeException) -> print ("No nix-store on system" :: String) + Right _ -> do + let go dir = do + srcHere <- doesDirectoryExist dir + bool + (pure ()) + (do + IO.withFile narFilePath IO.WriteMode $ \h -> + buildNarIO narEffectsIO "src" h + hnixNar <- BSL.readFile narFilePath + nixStoreNar <- getNixStoreDump "src" + HU.assertEqual + "src dir serializes the same between hnix-store and nix-store" + hnixNar + nixStoreNar + ) + srcHere + go "src" + go "hnix-store-core/src" + +-- 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" + 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" + narFilePath = packagePath <.> "nar" + + -- unused, see `step "check file exists"` bellow + _rmFiles = try @SomeException @() $ do + e <- doesPathExist narFilePath + when e $ removeDirectoryRecursive narFilePath + + _run = do + filesPrecount <- countProcessFiles + IO.withFile "hnar" IO.WriteMode $ \h -> + buildNarIO narEffectsIO narFilePath h + filesPostcount <- countProcessFiles + pure $ (-) <$> filesPostcount <*> filesPrecount + + step "create test files" + Directory.createDirectory packagePath + forM_ [0..1000] $ \i -> do + BSL.writeFile (Printf.printf (packagePath "%08d") (i :: Int)) "hi\n" + Concurrent.threadDelay 50 + + filesPrecount <- countProcessFiles + + step "pack nar" + IO.withFile narFilePath IO.WriteMode $ \h -> + buildNarIO narEffectsIO packagePath h + + step "unpack nar" + r <- IO.withFile narFilePath IO.ReadMode $ \h -> + unpackNarIO narEffectsIO h packagePath' + r `shouldBe` pure () + + step "check constant file usage" + filesPostcount <- countProcessFiles + case (-) <$> filesPostcount <*> filesPrecount of + Nothing -> pure () + Just c -> c `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 +-- `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 pure () + Left (_ :: SomeException) -> print ("No nix-store on system" :: String) + 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) + void $ withBytesAsHandle (runPut $ putNar n) $ \h -> + unpackNarIO narEffectsIO h testFile + + assertExists testFile + + -- nix-store converts those files to nar + getNixStoreDump testFile >>= BSL.writeFile nixNarFile + assertExists nixNarFile + + -- hnix converts those files to nar + IO.withFile hnixNarFile IO.WriteMode $ \h -> + buildNarIO narEffectsIO testFile h + assertExists hnixNarFile + + diffResult <- P.readProcess "diff" [nixNarFile, hnixNarFile] "" + + assertBoundedMemory + HU.assertEqual testErrorName diffResult "" + + +-- | Assert that GHC uses less than 100M memory at peak +assertBoundedMemory :: IO () +assertBoundedMemory = do +#ifdef BOUNDED_MEMORY + bytes <- max_live_bytes <$> getRTSStats + bytes < 100 * 1000 * 1000 `shouldBe` True +#else + pure () +#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 narFilePath = baseDir testName + + ver <- try (P.readProcess "nix-store" ["--version"] "") + case ver of + Left (_ :: SomeException) -> print ("No nix-store on system" :: String) + Right _ -> do + let + nixNarFile = narFilePath <> ".nix" + hnixNarFile = narFilePath <> ".hnix" + outputFile = narFilePath <> ".out" + + step $ "Produce nix-store nar to " <> nixNarFile + (_,_,_,handle) <- P.createProcess (P.shell $ "nix-store --dump " <> narFilePath <> " > " <> nixNarFile) + void $ P.waitForProcess handle + + step $ "Build NAR from " <> narFilePath <> " to " <> hnixNarFile + -- narBS <- buildNarIO narEffectsIO narFile + IO.withFile hnixNarFile IO.WriteMode $ \h -> + buildNarIO narEffectsIO narFilePath h + + -- Compare the hash digests of the two NARs + nixHash :: Digest SHA256 <- hash <$> BS.readFile nixNarFile + hnixHash :: Digest SHA256 <- hash <$> BS.readFile hnixNarFile + step $ unlines + [ "Compare SHA256 digests between NARs:" + , " nix: " <> show nixHash + , " hnix: " <> show hnixHash + ] + + HU.assertEqual "Hash mismatch between NARs" nixHash hnixHash + + step $ "Unpack NAR to " <> outputFile + _narHandle <- IO.withFile nixNarFile IO.ReadMode $ \h -> + unpackNarIO narEffectsIO h outputFile + + pure () + +-- | Count file descriptors owned by the current process +countProcessFiles :: IO (Maybe Int) +countProcessFiles = do + pid <- Unix.getProcessID + hasProc <- doesDirectoryExist "/proc" + if not hasProc + then pure Nothing + else do + let fdDir = "/proc/" <> show pid <> "/fd" + fds <- P.readProcess "ls" [fdDir] "" + pure $ pure $ length $ words fds + + +-- | 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 \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 :: Int]] + <> [ + (FilePathPart "d", Directory $ Map.fromList + [ (FilePathPart (BSC.pack $ "df" <> show n) + , Regular NonExecutable 10000 (BSL.take 10000 (BSL.cycle "subhi "))) + | n <- [1..100 :: Int]] + ) + ] + +sampleLinkToDirectory :: FileSystemObject +sampleLinkToDirectory = Directory $ Map.fromList [ + (FilePathPart "foo", Directory $ Map.fromList [ + (FilePathPart "file", Regular NonExecutable 8 "foo text") + ]) + , (FilePathPart "linkfoo" , SymLink "foo") + ] + +-------------------------------------------------------------------------------- +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` + +-- "hi" file turned to a NAR with `nix-store --dump`, Base64 encoded +sampleRegularBaseline :: BSC.ByteString +sampleRegularBaseline = B64.decodeLenient $ BSC.concat + ["DQAAAAAAAABuaXgtYXJjaGl2ZS0xAAAAAQAAAAAAAAAoAAAAAAA" + ,"AAAQAAAAAAAAAdHlwZQAAAAAHAAAAAAAAAHJlZ3VsYXIACAAAAA" + ,"AAAABjb250ZW50cwMAAAAAAAAAaGkKAAAAAAABAAAAAAAAACkAA" + ,"AAAAAAA" + ] + +sampleRegular'Baseline :: BSC.ByteString +sampleRegular'Baseline = B64.decodeLenient $ BSC.concat + ["DQAAAAAAAABuaXgtYXJjaGl2ZS0xAAAAAQAAAAAAAAAoAAAAAAA" + ,"AAAQAAAAAAAAAdHlwZQAAAAAHAAAAAAAAAHJlZ3VsYXIACAAAAA" + ,"AAAABjb250ZW50c0AAAAAAAAAAI2luY2x1ZGUgPHN0ZGlvLmg+C" + ,"gppbnQgbWFpbihpbnQgYXJnYywgY2hhciAqYXJndltdKXsgZXhp" + ,"dCAwOyB9CgEAAAAAAAAAKQAAAAAAAAA=" + ] + +sampleExecutableBaseline :: BSC.ByteString +sampleExecutableBaseline = B64.decodeLenient $ BSC.concat + ["DQAAAAAAAABuaXgtYXJjaGl2ZS0xAAAAAQAAAAAAAAAoAAAAAAA" + ,"AAAQAAAAAAAAAdHlwZQAAAAAHAAAAAAAAAHJlZ3VsYXIACgAAAA" + ,"AAAABleGVjdXRhYmxlAAAAAAAAAAAAAAAAAAAIAAAAAAAAAGNvb" + ,"nRlbnRzIgAAAAAAAAAjIS9iaW4vYmFzaAoKZ2NjIC1vIGhlbGxv" + ,"IGhlbGxvLmMKAAAAAAAAAQAAAAAAAAApAAAAAAAAAA==" + ] + +sampleSymLinkBaseline :: BSC.ByteString +sampleSymLinkBaseline = B64.decodeLenient $ BSC.concat + ["DQAAAAAAAABuaXgtYXJjaGl2ZS0xAAAAAQAAAAAAAAAoAAAAAAA" + ,"AAAQAAAAAAAAAdHlwZQAAAAAHAAAAAAAAAHN5bWxpbmsABgAAAA" + ,"AAAAB0YXJnZXQAAAcAAAAAAAAAaGVsbG8uYwABAAAAAAAAACkAA" + ,"AAAAAAA" + ] + +sampleDirectoryBaseline :: BSC.ByteString +sampleDirectoryBaseline = B64.decodeLenient $ BSC.concat + ["DQAAAAAAAABuaXgtYXJjaGl2ZS0xAAAAAQAAAAAAAAAoAAAAAAA" + ,"AAAQAAAAAAAAAdHlwZQAAAAAJAAAAAAAAAGRpcmVjdG9yeQAAAA" + ,"AAAAAFAAAAAAAAAGVudHJ5AAAAAQAAAAAAAAAoAAAAAAAAAAQAA" + ,"AAAAAAAbmFtZQAAAAAIAAAAAAAAAGJ1aWxkLnNoBAAAAAAAAABu" + ,"b2RlAAAAAAEAAAAAAAAAKAAAAAAAAAAEAAAAAAAAAHR5cGUAAAA" + ,"ABwAAAAAAAAByZWd1bGFyAAoAAAAAAAAAZXhlY3V0YWJsZQAAAA" + ,"AAAAAAAAAAAAAACAAAAAAAAABjb250ZW50cyIAAAAAAAAAIyEvY" + ,"mluL2Jhc2gKCmdjYyAtbyBoZWxsbyBoZWxsby5jCgAAAAAAAAEA" + ,"AAAAAAAAKQAAAAAAAAABAAAAAAAAACkAAAAAAAAABQAAAAAAAAB" + ,"lbnRyeQAAAAEAAAAAAAAAKAAAAAAAAAAEAAAAAAAAAG5hbWUAAA" + ,"AABwAAAAAAAABoZWxsby5jAAQAAAAAAAAAbm9kZQAAAAABAAAAA" + ,"AAAACgAAAAAAAAABAAAAAAAAAB0eXBlAAAAAAcAAAAAAAAAcmVn" + ,"dWxhcgAIAAAAAAAAAGNvbnRlbnRzQAAAAAAAAAAjaW5jbHVkZSA" + ,"8c3RkaW8uaD4KCmludCBtYWluKGludCBhcmdjLCBjaGFyICphcm" + ,"d2W10peyBleGl0IDA7IH0KAQAAAAAAAAApAAAAAAAAAAEAAAAAA" + ,"AAAKQAAAAAAAAAFAAAAAAAAAGVudHJ5AAAAAQAAAAAAAAAoAAAA" + ,"AAAAAAQAAAAAAAAAbmFtZQAAAAAEAAAAAAAAAGhpLmMAAAAABAA" + ,"AAAAAAABub2RlAAAAAAEAAAAAAAAAKAAAAAAAAAAEAAAAAAAAAH" + ,"R5cGUAAAAABwAAAAAAAABzeW1saW5rAAYAAAAAAAAAdGFyZ2V0A" + ,"AAHAAAAAAAAAGhlbGxvLmMAAQAAAAAAAAApAAAAAAAAAAEAAAAA" + ,"AAAAKQAAAAAAAAABAAAAAAAAACkAAAAAAAAA" + ] + +sampleLinkToDirectoryBaseline :: BSC.ByteString +sampleLinkToDirectoryBaseline = B64.decodeLenient $ BSC.concat + ["DQAAAAAAAABuaXgtYXJjaGl2ZS0xAAAAAQAAAAAAAAAoAAAAAAAAAAQAAAAAAAAAdHlwZQAAAAAJ" + ,"AAAAAAAAAGRpcmVjdG9yeQAAAAAAAAAFAAAAAAAAAGVudHJ5AAAAAQAAAAAAAAAoAAAAAAAAAAQA" + ,"AAAAAAAAbmFtZQAAAAADAAAAAAAAAGZvbwAAAAAABAAAAAAAAABub2RlAAAAAAEAAAAAAAAAKAAA" + ,"AAAAAAAEAAAAAAAAAHR5cGUAAAAACQAAAAAAAABkaXJlY3RvcnkAAAAAAAAABQAAAAAAAABlbnRy" + ,"eQAAAAEAAAAAAAAAKAAAAAAAAAAEAAAAAAAAAG5hbWUAAAAABAAAAAAAAABmaWxlAAAAAAQAAAAA" + ,"AAAAbm9kZQAAAAABAAAAAAAAACgAAAAAAAAABAAAAAAAAAB0eXBlAAAAAAcAAAAAAAAAcmVndWxh" + ,"cgAIAAAAAAAAAGNvbnRlbnRzCAAAAAAAAABmb28gdGV4dAEAAAAAAAAAKQAAAAAAAAABAAAAAAAA" + ,"ACkAAAAAAAAAAQAAAAAAAAApAAAAAAAAAAEAAAAAAAAAKQAAAAAAAAAFAAAAAAAAAGVudHJ5AAAA" + ,"AQAAAAAAAAAoAAAAAAAAAAQAAAAAAAAAbmFtZQAAAAAHAAAAAAAAAGxpbmtmb28ABAAAAAAAAABu" + ,"b2RlAAAAAAEAAAAAAAAAKAAAAAAAAAAEAAAAAAAAAHR5cGUAAAAABwAAAAAAAABzeW1saW5rAAYA" + ,"AAAAAAAAdGFyZ2V0AAADAAAAAAAAAGZvbwAAAAAAAQAAAAAAAAApAAAAAAAAAAEAAAAAAAAAKQAA" + ,"AAAAAAABAAAAAAAAACkAAAAAAAAA" + ] + +-- | Control testcase sizes (bytes) by env variable +getBigFileSize :: IO Int64 +getBigFileSize = fromMaybe 5000000 . readMaybe <$> (getEnv "HNIX_BIG_FILE_SIZE" <|> pure "") + +-- TODO: implement and use in generator #232 +-- | 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 + +mkBigFile :: FilePath -> IO () +mkBigFile path = do + fsize <- getBigFileSize + BSL.writeFile path (BSL.take fsize $ BSL.cycle "Lorem ipsum") + +mkExecutableFile :: FilePath -> IO () +mkExecutableFile path = do + BSL.writeFile path "" + st <- Unix.getSymbolicLinkStatus path + let p = Unix.fileMode st `Unix.unionFileModes` Unix.ownerExecuteMode + Unix.setFileMode path p + +-- | Construct FilePathPart from Text by checking that there +-- are no '/' or '\\NUL' characters +filePathPart :: BSC.ByteString -> Maybe FilePathPart +filePathPart p = if BSC.any (`elem` ['/', '\NUL']) p then Nothing else Just $ FilePathPart p + +newtype Nar = Nar { narFile :: FileSystemObject } + deriving (Eq, Show, Generic) + +-- | 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) + +-- | A valid filename or directory name +newtype FilePathPart = FilePathPart { unFilePathPart :: BSC.ByteString } + deriving (Eq, Ord, Show) + +instance Serialize Nar where + get = getNar + put = putNar + +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)] + pure (nm,f) + +------------------------------------------------------------------------------ +-- | Serialize Nar to ByteString +putNar :: Putter Nar +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 pure ()) + >> putContents fSize (BSL.toStrict contents) + + putFile (SymLink target) = + strs ["type", "symlink", "target", 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 name + str "node" + parens (putFile fso) + + parens m = str "(" >> m >> str ")" + + -- Do not use this for file contents + str :: Putter BS.ByteString + str t = let len = BS.length t + in int len <> pad (fromIntegral len) t + + putContents :: Int64 -> Putter BS.ByteString + putContents fSize bs = str "contents" <> int fSize <> pad fSize bs + + int :: Integral a => Putter a + int n = putInt64le $ fromIntegral n + + pad :: Int64 -> Putter BS.ByteString + pad strSize bs = do + putByteString bs + putByteString (BS.replicate (fromIntegral (padLen strSize)) 0) + + strs :: Putter [BS.ByteString] + strs = mapM_ str + +-- | Distance to the next multiple of 8 +padLen :: Int64 -> Int64 +padLen n = (8 - n) `mod` 8 + + +------------------------------------------------------------------------------ +-- | Deserialize a Nar from 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 $ Executable <$ (assertStr "executable" + >> assertStr "") + assertStr_ "contents" + (fSize, contents) <- sizedStr + pure $ Regular (fromMaybe NonExecutable mExecutable) fSize contents + + getDirectory = do + assertStr_ "type" + assertStr_ "directory" + fs <- many getEntry + pure $ 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 <- str + assertStr_ "node" + file <- parens getFile + maybe (fail $ "Bad FilePathPart: " <> show name) + (pure . (,file)) + (filePathPart $ BSLC.toStrict name) + + -- Fetch a length-prefixed, null-padded string + str = fmap snd sizedStr + + sizedStr = do + n <- getInt64le + s <- getLazyByteString n + _ <- getByteString . fromIntegral $ padLen n + pure (n,s) + + parens m = assertStr "(" *> m <* assertStr ")" + + assertStr_ = void . assertStr + assertStr s = do + s' <- str + if s == s' + then pure s + else fail "No" + +------------------------------------------------------------------------------ +-- | Deserialize from binary file +decodeFile :: Serialize a => FilePath -> IO a +decodeFile f = do + bs <- BS.readFile f + let result = runGet get bs + case result of + Left reason -> error reason + Right output -> pure output diff --git a/tests/fixtures/case-conflict.nar b/tests/fixtures/case-conflict.nar new file mode 100644 Binary files /dev/null and b/tests/fixtures/case-conflict.nar differ