hnix-store-nar (empty) → 0.1.0.0
raw patch · 12 files changed
+2062/−0 lines, 12 filesdep +algebraic-graphsdep +basedep +base64-bytestringbinary-added
Dependencies added: algebraic-graphs, base, base64-bytestring, bytestring, case-insensitive, cereal, containers, cryptonite, directory, filepath, hnix-store-nar, hspec, lifted-base, monad-control, mtl, process, tasty, tasty-hspec, tasty-hunit, tasty-quickcheck, temporary, text, unix, unordered-containers
Files
- CHANGELOG.md +9/−0
- LICENSE +201/−0
- README.md +8/−0
- hnix-store-nar.cabal +117/−0
- src/System/Nix/Nar.hs +69/−0
- src/System/Nix/Nar/Effects.hs +148/−0
- src/System/Nix/Nar/Options.hs +30/−0
- src/System/Nix/Nar/Parser.hs +541/−0
- src/System/Nix/Nar/Streamer.hs +155/−0
- tests/Driver.hs +1/−0
- tests/NarFormat.hs +783/−0
- tests/fixtures/case-conflict.nar binary
+ CHANGELOG.md view
@@ -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
+ LICENSE view
@@ -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.
+ README.md view
@@ -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
+ hnix-store-nar.cabal view
@@ -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
+ src/System/Nix/Nar.hs view
@@ -0,0 +1,69 @@+{-+Description : Generating and consuming NAR files+Maintainer : Shea Levy <shea@shealevy.com>+-}++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
+ src/System/Nix/Nar/Effects.hs view
@@ -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
+ src/System/Nix/Nar/Options.hs view
@@ -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~"
+ src/System/Nix/Nar/Parser.hs view
@@ -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)
+ src/System/Nix/Nar/Streamer.hs view
@@ -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
+ tests/Driver.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}
+ tests/NarFormat.hs view
@@ -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 <stdio.h>\n\nint main(int argc, char *argv[]){ exit 0; }\n"++-- | Executable file+sampleExecutable :: FileSystemObject+sampleExecutable = Regular Executable (BSL.length str) str+ where str = "#!/bin/bash\n\ngcc -o hello hello.c\n"++-- | A simple symlink+sampleSymLink :: FileSystemObject+sampleSymLink = SymLink "hello.c"+++-- | A directory that includes some of the above sample files+sampleDirectory :: FileSystemObject+sampleDirectory = Directory $ Map.fromList+ [(FilePathPart "hello.c", sampleRegular')+ ,(FilePathPart "build.sh", sampleExecutable)+ ,(FilePathPart "hi.c", sampleSymLink)+ ]++-- | A deeper directory tree with crossing links+sampleDirectory' :: FileSystemObject+sampleDirectory' = Directory $ Map.fromList [++ (FilePathPart "foo", Directory $ Map.fromList [+ (FilePathPart "foo.txt", Regular NonExecutable 8 "foo text")+ , (FilePathPart "tobar" , SymLink "../bar/bar.txt")+ ])++ , (FilePathPart "bar", Directory $ Map.fromList [+ (FilePathPart "bar.txt", Regular NonExecutable 8 "bar text")+ , (FilePathPart "tofoo" , SymLink "../foo/foo.txt")+ ])+ ]++sampleLargeFile :: Int64 -> FileSystemObject+sampleLargeFile fSize =+ Regular NonExecutable fSize (BSL.take fSize (BSL.cycle "Lorem ipsum "))+++sampleLargeFile' :: Int64 -> FileSystemObject+sampleLargeFile' fSize =+ Regular NonExecutable fSize (BSL.take fSize (BSL.cycle "Lorems ipsums "))++sampleLargeDir :: Int64 -> FileSystemObject+sampleLargeDir fSize = Directory $ Map.fromList $ [+ (FilePathPart "bf1", sampleLargeFile fSize)+ , (FilePathPart "bf2", sampleLargeFile' fSize)+ ]+ <> [ (FilePathPart (BSC.pack $ 'f' : show n),+ Regular NonExecutable 10000 (BSL.take 10000 (BSL.cycle "hi ")))+ | n <- [1..100 :: 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
+ tests/fixtures/case-conflict.nar view
binary file changed (absent → 1000 bytes)