diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for hnix-store-core + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. 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,15 @@ +hnix-store-core +================= + +Core effects for interacting with the Nix store. + +See `StoreEffects` in [System.Nix.Store] for the available operations +on the store. + +[System.Nix.Store]: ./src/System/Nix/Store.hs + + +Tests +====== + + - `ghcid --command "cabal repl test-suite:format-tests" --test="Main.main"` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hnix-store-core.cabal b/hnix-store-core.cabal new file mode 100644 --- /dev/null +++ b/hnix-store-core.cabal @@ -0,0 +1,84 @@ +name: hnix-store-core +version: 0.1.0.0 +synopsis: Core effects for interacting with the Nix store. +description: + This package contains types and functions needed to describe + interactions with the Nix store abstracted away from + specific effectful context. +homepage: https://github.com/haskell-nix/hnix-store +license: Apache-2.0 +license-file: LICENSE +author: Shea Levy +maintainer: shea@shealevy.com +copyright: 2018 Shea Levy +category: System +build-type: Simple +extra-source-files: ChangeLog.md, README.md +cabal-version: >=1.10 + +library + exposed-modules: System.Nix.Base32 + , System.Nix.Build + , System.Nix.Derivation + , System.Nix.GC + , System.Nix.Hash + , System.Nix.Internal.Hash + , System.Nix.Nar + , System.Nix.Path + , System.Nix.ReadonlyStore + , System.Nix.Store + , System.Nix.Util + build-depends: base >=4.10 && <5 + , base16-bytestring + , bytestring + , binary + , bytestring + , containers + , cryptohash-md5 + , cryptohash-sha1 + , cryptohash-sha256 + , directory + , filepath + , hashable + , mtl + , regex-base + , regex-tdfa-text + , text + , unix + , unordered-containers + , vector + hs-source-dirs: src + default-language: Haskell2010 + +Flag bounded_memory + description: Run tests of constant memory use (requires +RTS -T) + default: False + +test-suite format-tests + if flag(bounded_memory) + cpp-options: -DBOUNDED_MEMORY + ghc-options: -rtsopts -fprof-auto + type: exitcode-stdio-1.0 + main-is: Driver.hs + other-modules: + NarFormat + Hash + hs-source-dirs: + tests + build-depends: + hnix-store-core + , base + , base64-bytestring + , binary + , bytestring + , containers + , directory + , process + , tasty + , tasty-discover + , tasty-hspec + , tasty-hunit + , tasty-quickcheck + , temporary + , text + default-language: Haskell2010 diff --git a/src/System/Nix/Base32.hs b/src/System/Nix/Base32.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Base32.hs @@ -0,0 +1,31 @@ +{-| +Description: Implementation of Nix's base32 encoding. +-} +module System.Nix.Base32 where + +import qualified Data.ByteString as BS +import qualified Data.Text as T +import qualified Data.Vector as V + +-- | Encode a 'BS.ByteString' in Nix's base32 encoding +encode :: BS.ByteString -> T.Text +encode c = T.pack $ concatMap char32 [nChar - 1, nChar - 2 .. 0] + where + digits32 = V.fromList "0123456789abcdfghijklmnpqrsvwxyz" + -- The base32 encoding is 8/5's as long as the base256 digest. This `+ 1` + -- `- 1` business is a bit odd, but has always been used in C++ since the + -- base32 truncation was added in was first added in + -- d58a11e019813902b6c4547ca61a127938b2cc20. + nChar = fromIntegral $ ((BS.length c * 8 - 1) `div` 5) + 1 + + char32 :: Integer -> [Char] + char32 i = [digits32 V.! digitInd] + where + byte j = BS.index c (fromIntegral j) + fromIntegral' :: Num b => Integer -> b + fromIntegral' = fromIntegral + digitInd = fromIntegral' $ + sum [fromIntegral (byte j) * (256^j) + | j <- [0 .. BS.length c - 1]] + `div` (32^i) + `mod` 32 diff --git a/src/System/Nix/Build.hs b/src/System/Nix/Build.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Build.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE RecordWildCards #-} +{-| +Description : Build related types +Maintainer : srk +|-} +module System.Nix.Build ( + BuildMode(..) + , BuildStatus(..) + , BuildResult(..) + , buildSuccess + ) where + +import Data.Text (Text) +import Data.HashSet (HashSet) +import System.Nix.Path (Path) + +data BuildMode = Normal | Repair | Check + deriving (Eq, Ord, Enum, Show) + +data BuildStatus = + Built + | Substituted + | AlreadyValid + | PermanentFailure + | InputRejected + | OutputRejected + | TransientFailure -- possibly transient + | CachedFailure -- no longer used + | TimedOut + | MiscFailure + | DependencyFailed + | LogLimitExceeded + | NotDeterministic + deriving (Eq, Ord, Enum, Show) + + +-- | Result of the build +data BuildResult = BuildResult + { -- | build status, MiscFailure should be default + status :: !BuildStatus + , -- | possible build error message + error :: !(Maybe Text) + , -- | How many times this build was performed + timesBuilt :: !Integer + , -- | If timesBuilt > 1, whether some builds did not produce the same result + isNonDeterministic :: !Bool + -- XXX: | startTime stopTime time_t + } deriving (Eq, Ord, Show) + +buildSuccess BuildResult{..} = status == Built || status == Substituted || status == AlreadyValid diff --git a/src/System/Nix/Derivation.hs b/src/System/Nix/Derivation.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Derivation.hs @@ -0,0 +1,30 @@ +{-| +Description : Derivation types +Maintainer : srk +|-} + +module System.Nix.Derivation where + + +import Data.Text (Text) +import Data.HashMap.Strict (HashMap) +import Data.HashSet (HashSet) +import System.Nix.Path + +type OutputName = Text + +newtype DerivationInputs = DerivationInputs + { _unDerivationInputs :: HashMap Path (HashSet OutputName) + } deriving (Eq, Ord, Show) + +data Derivation = Derivation + { _derivationInputs :: DerivationInputs + , _derivationOutputs :: !(HashMap OutputName Path) + -- | Inputs that are sources + , _derivationInputSrcs :: !PathSet + , _derivationPlatform :: !Text + -- | Path to builder + , _derivationBuilder :: !Path + , _derivationArgs :: ![Text] + , _derivationEnv :: ![HashMap Text Text] + } deriving (Eq, Ord, Show) diff --git a/src/System/Nix/GC.hs b/src/System/Nix/GC.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/GC.hs @@ -0,0 +1,47 @@ +{-| +Description : Garbage collection actions / options +Maintainer : srk +|-} +module System.Nix.GC ( + Action(..) + , Options(..) + , Result(..) + ) where + +import System.Nix.Path (PathSet) + +{- Garbage collector operation: + - ReturnLive: return the set of paths reachable from + (i.e. in the closure of) the roots. + - ReturnDead: return the set of paths not reachable from + the roots. + - DeleteDead: actually delete the latter set. + - DeleteSpecific: delete the paths listed in + `pathsToDelete', insofar as they are not reachable. +-} + +data Action = ReturnLive | ReturnDead | DeleteDead | DeleteSpecific + deriving (Eq, Ord, Enum, Show) + +-- | Garbage collector operation options +data Options = Options + { -- | operation + operation :: !Action + -- | If `ignoreLiveness' is set, then reachability from the roots is + -- ignored (dangerous!). However, the paths must still be + -- unreferenced *within* the store (i.e., there can be no other + -- store paths that depend on them). + , ignoreLiveness :: !Bool + -- | For DeleteSpecific, the paths to delete + , pathsToDelete :: !PathSet + , -- | Stop after at least `maxFreed` bytes have been freed + maxFreed :: !Integer + } deriving (Eq, Ord, Show) + +data Result = Result + { -- | Depending on the action, the GC roots, or the paths that would be or have been deleted + paths :: !PathSet + , -- | For ReturnDead, DeleteDead and DeleteSpecific, the number of bytes that would be or was freed + bytesFreed :: !Integer + } deriving (Eq, Ord, Show) + diff --git a/src/System/Nix/Hash.hs b/src/System/Nix/Hash.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Hash.hs @@ -0,0 +1,17 @@ +{-| +Description : Cryptographic hashes for hnix-store. +-} +module System.Nix.Hash ( + HNix.Digest + + , HNix.HashAlgorithm(..) + , HNix.ValidAlgo(..) + , HNix.NamedAlgo(..) + , HNix.hash + , HNix.hashLazy + + , HNix.encodeBase32 + , HNix.encodeBase16 + ) where + +import qualified System.Nix.Internal.Hash as HNix diff --git a/src/System/Nix/Internal/Hash.hs b/src/System/Nix/Internal/Hash.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Internal/Hash.hs @@ -0,0 +1,154 @@ +{-| +Description : Cryptographic hashing interface for hnix-store, on top + of the cryptohash family of libraries. +-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +module System.Nix.Internal.Hash where + +import qualified Crypto.Hash.MD5 as MD5 +import qualified Crypto.Hash.SHA1 as SHA1 +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as Base16 +import Data.Bits (xor) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Hashable as DataHashable +import Data.List (foldl') +import Data.Proxy (Proxy(Proxy)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Word (Word8) +import GHC.TypeLits (Nat, KnownNat, natVal) +import qualified System.Nix.Base32 as Base32 + +-- | The universe of supported hash algorithms. +-- +-- Currently only intended for use at the type level. +data HashAlgorithm + = MD5 + | SHA1 + | SHA256 + | Truncated Nat HashAlgorithm + -- ^ The hash algorithm obtained by truncating the result of the + -- input 'HashAlgorithm' to the given number of bytes. See + -- 'truncateDigest' for a description of the truncation algorithm. + +-- | The result of running a 'HashAlgorithm'. +newtype Digest (a :: HashAlgorithm) = + Digest BS.ByteString deriving (Show, Eq, Ord, DataHashable.Hashable) + +-- | The primitive interface for incremental hashing for a given +-- 'HashAlgorithm'. Every 'HashAlgorithm' should have an instance. +class ValidAlgo (a :: HashAlgorithm) where + -- | The incremental state for constructing a hash. + type AlgoCtx a + + -- | Start building a new hash. + initialize :: AlgoCtx a + -- | Append a 'BS.ByteString' to the overall contents to be hashed. + update :: AlgoCtx a -> BS.ByteString -> AlgoCtx a + -- | Finish hashing and generate the output. + finalize :: AlgoCtx a -> Digest a + +-- | A 'HashAlgorithm' with a canonical name, for serialization +-- purposes (e.g. SRI hashes) +class NamedAlgo (a :: HashAlgorithm) where + algoName :: Text + +instance NamedAlgo 'MD5 where + algoName = "md5" + +instance NamedAlgo 'SHA1 where + algoName = "sha1" + +instance NamedAlgo 'SHA256 where + algoName = "sha256" + +-- | Hash an entire (strict) 'BS.ByteString' as a single call. +-- +-- For example: +-- > let d = hash "Hello, sha-256!" :: Digest SHA256 +-- or +-- > :set -XTypeApplications +-- > let d = hash @SHA256 "Hello, sha-256!" +hash :: forall a.ValidAlgo a => BS.ByteString -> Digest a +hash bs = + finalize $ update @a (initialize @a) bs + +-- | Hash an entire (lazy) 'BSL.ByteString' as a single call. +-- +-- Use is the same as for 'hash'. This runs in constant space, but +-- forces the entire bytestring. +hashLazy :: forall a.ValidAlgo a => BSL.ByteString -> Digest a +hashLazy bsl = + finalize $ foldl' (update @a) (initialize @a) (BSL.toChunks bsl) + +-- | Encode a 'Digest' in the special Nix base-32 encoding. +encodeBase32 :: Digest a -> T.Text +encodeBase32 (Digest bs) = Base32.encode bs + +-- | Encode a 'Digest' in hex. +encodeBase16 :: Digest a -> T.Text +encodeBase16 (Digest bs) = T.decodeUtf8 (Base16.encode bs) + +-- | Uses "Crypto.Hash.MD5" from cryptohash-md5. +instance ValidAlgo 'MD5 where + type AlgoCtx 'MD5 = MD5.Ctx + initialize = MD5.init + update = MD5.update + finalize = Digest . MD5.finalize + +-- | Uses "Crypto.Hash.SHA1" from cryptohash-sha1. +instance ValidAlgo 'SHA1 where + type AlgoCtx 'SHA1 = SHA1.Ctx + initialize = SHA1.init + update = SHA1.update + finalize = Digest . SHA1.finalize + +-- | Uses "Crypto.Hash.SHA256" from cryptohash-sha256. +instance ValidAlgo 'SHA256 where + type AlgoCtx 'SHA256 = SHA256.Ctx + initialize = SHA256.init + update = SHA256.update + finalize = Digest . SHA256.finalize + +-- | Reuses the underlying 'ValidAlgo' instance, but does a +-- 'truncateDigest' at the end. +instance (ValidAlgo a, KnownNat n) => ValidAlgo ('Truncated n a) where + type AlgoCtx ('Truncated n a) = AlgoCtx a + initialize = initialize @a + update = update @a + finalize = truncateDigest @n . finalize @a + +-- | Bytewise truncation of a 'Digest'. +-- +-- When truncation length is greater than the length of the bytestring +-- but less than twice the bytestring length, truncation splits the +-- bytestring into a head part (truncation length) and tail part +-- (leftover part), right-pads the leftovers with 0 to the truncation +-- length, and combines the two strings bytewise with 'xor'. +truncateDigest + :: forall n a.(KnownNat n) => Digest a -> Digest ('Truncated n a) +truncateDigest (Digest c) = + Digest $ BS.pack $ map truncOutputByte [0.. n-1] + where + n = fromIntegral $ natVal (Proxy @n) + + truncOutputByte :: Int -> Word8 + truncOutputByte i = foldl' (aux i) 0 [0 .. BS.length c - 1] + + inputByte :: Int -> Word8 + inputByte j = BS.index c (fromIntegral j) + + aux :: Int -> Word8 -> Int -> Word8 + aux i x j = if j `mod` fromIntegral n == fromIntegral i + then xor x (inputByte $ fromIntegral j) + else x 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,267 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +{-| +Description : Allowed effects for interacting with Nar files. +Maintainer : Shea Levy +|-} +module System.Nix.Nar ( + FileSystemObject(..) + , IsExecutable (..) + , Nar(..) + , getNar + , localPackNar + , localUnpackNar + , narEffectsIO + , putNar + ) where + +import Control.Applicative +import Control.Monad (replicateM, replicateM_, (<=<)) +import qualified Data.Binary as B +import qualified Data.Binary.Get as B +import qualified Data.Binary.Put as B +import Data.Bool (bool) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BSL +import Data.Foldable (forM_) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import Data.Traversable (forM) +import GHC.Int (Int64) +import System.Directory +import System.FilePath +import System.Posix.Files (createSymbolicLink, fileSize, getFileStatus, + isDirectory, readSymbolicLink) + +import System.Nix.Path + +data NarEffects (m :: * -> *) = NarEffects { + narReadFile :: FilePath -> m BSL.ByteString + , narWriteFile :: FilePath -> BSL.ByteString -> m () + , narListDir :: FilePath -> m [FilePath] + , narCreateDir :: FilePath -> m () + , narCreateLink :: FilePath -> FilePath -> m () + , narGetPerms :: FilePath -> m Permissions + , narSetPerms :: FilePath -> Permissions -> m () + , narIsDir :: FilePath -> m Bool + , narIsSymLink :: FilePath -> m Bool + , narFileSize :: FilePath -> m Int64 + , narReadLink :: FilePath -> m FilePath +} + + +-- Directly taken from Eelco thesis +-- https://nixos.org/%7Eeelco/pubs/phd-thesis.pdf + +data Nar = Nar { narFile :: FileSystemObject } + deriving (Eq, Show) + +-- | A FileSystemObject (FSO) is an anonymous entity that can be NAR archived +data FileSystemObject = + Regular IsExecutable Int64 BSL.ByteString + -- ^ Reguar file, with its executable state, size (bytes) and contents + | Directory (Map.Map FilePathPart FileSystemObject) + -- ^ Directory with mapping of filenames to sub-FSOs + | SymLink T.Text + -- ^ Symbolic link target + deriving (Eq, Show) + + +data IsExecutable = NonExecutable | Executable + deriving (Eq, Show) + + +instance B.Binary Nar where + get = getNar + put = putNar + +------------------------------------------------------------------------------ +-- | Serialize Nar to lazy ByteString +putNar :: Nar -> B.Put +putNar (Nar file) = header <> parens (putFile file) + where + + header = str "nix-archive-1" + + putFile (Regular isExec fSize contents) = + strs ["type", "regular"] + >> (if isExec == Executable + then strs ["executable", ""] + else return ()) + >> putContents fSize contents + + putFile (SymLink target) = + strs ["type", "symlink", "target", BSL.fromStrict $ E.encodeUtf8 target] + + -- toList sorts the entries by FilePathPart before serializing + putFile (Directory entries) = + strs ["type", "directory"] + <> mapM_ putEntry (Map.toList entries) + + putEntry (FilePathPart name, fso) = do + str "entry" + parens $ do + str "name" + str (BSL.fromStrict name) + str "node" + parens (putFile fso) + + parens m = str "(" >> m >> str ")" + + -- Do not use this for file contents + str :: BSL.ByteString -> B.Put + str t = let len = BSL.length t + in int len <> pad len t + + putContents :: Int64 -> BSL.ByteString -> B.Put + putContents fSize bs = str "contents" <> int fSize <> (pad fSize bs) + -- putContents fSize bs = str "contents" <> int (BSL.length bs) <> (pad fSize bs) + + int :: Integral a => a -> B.Put + int n = B.putInt64le $ fromIntegral n + + pad :: Int64 -> BSL.ByteString -> B.Put + pad strSize bs = do + B.putLazyByteString bs + B.putLazyByteString (BSL.replicate (padLen strSize) 0) + + strs :: [BSL.ByteString] -> B.Put + strs = mapM_ str + + +------------------------------------------------------------------------------ +-- | Deserialize a Nar from lazy ByteString +getNar :: B.Get Nar +getNar = fmap Nar $ header >> parens getFile + where + + header = assertStr "nix-archive-1" + + + -- Fetch a FileSystemObject + getFile = getRegularFile <|> getDirectory <|> getSymLink + + getRegularFile = do + assertStr "type" + assertStr "regular" + mExecutable <- optional $ Executable <$ (assertStr "executable" + >> assertStr "") + assertStr "contents" + (fSize, contents) <- sizedStr + return $ Regular (fromMaybe NonExecutable mExecutable) fSize contents + + getDirectory = do + assertStr "type" + assertStr "directory" + fs <- many getEntry + return $ Directory (Map.fromList fs) + + getSymLink = do + assertStr "type" + assertStr "symlink" + assertStr "target" + fmap (SymLink . E.decodeUtf8 . BSL.toStrict) str + + getEntry = do + assertStr "entry" + parens $ do + assertStr "name" + name <- E.decodeUtf8 . BSL.toStrict <$> str + assertStr "node" + file <- parens getFile + maybe (fail $ "Bad FilePathPart: " ++ show name) + (return . (,file)) + (filePathPart $ E.encodeUtf8 name) + + -- Fetch a length-prefixed, null-padded string + str = fmap snd sizedStr + + sizedStr = do + n <- B.getInt64le + s <- B.getLazyByteString n + p <- B.getByteString . fromIntegral $ padLen n + return (n,s) + + parens m = assertStr "(" *> m <* assertStr ")" + + assertStr s = do + s' <- str + if s == s' + then return s + else fail "No" + + +-- | Distance to the next multiple of 8 +padLen :: Int64 -> Int64 +padLen n = (8 - n) `mod` 8 + + +-- | Unpack a NAR into a non-nix-store directory (e.g. for testing) +localUnpackNar :: Monad m => NarEffects m -> FilePath -> Nar -> m () +localUnpackNar effs basePath (Nar fso) = localUnpackFSO basePath fso + + where + + localUnpackFSO basePath fso = case fso of + + Regular isExec _ bs -> do + (narWriteFile effs) basePath bs + p <- narGetPerms effs basePath + (narSetPerms effs) basePath (p {executable = isExec == Executable}) + + SymLink targ -> narCreateLink effs (T.unpack targ) basePath + + Directory contents -> do + narCreateDir effs basePath + forM_ (Map.toList contents) $ \(FilePathPart path', fso) -> + localUnpackFSO (basePath BSC.unpack path') fso + + +-- | Pack a NAR from a filepath +localPackNar :: Monad m => NarEffects m -> FilePath -> m Nar +localPackNar effs basePath = Nar <$> localPackFSO basePath + + where + + localPackFSO path' = do + fType <- (,) <$> narIsDir effs path' <*> narIsSymLink effs path' + case fType of + (_, True) -> SymLink . T.pack <$> narReadLink effs path' + (False, _) -> Regular <$> isExecutable effs path' + <*> narFileSize effs path' + <*> narReadFile effs path' + (True , _) -> fmap (Directory . Map.fromList) $ do + fs <- narListDir effs path' + forM fs $ \fp -> + (FilePathPart (BSC.pack $ fp),) <$> localPackFSO (path' fp) + + + +narEffectsIO :: NarEffects IO +narEffectsIO = NarEffects { + narReadFile = BSL.readFile + , narWriteFile = BSL.writeFile + , narListDir = listDirectory + , narCreateDir = createDirectory + , narCreateLink = createSymbolicLink + , narGetPerms = getPermissions + , narSetPerms = setPermissions + , narIsDir = fmap isDirectory <$> getFileStatus + , narIsSymLink = pathIsSymbolicLink + , narFileSize = fmap (fromIntegral . fileSize) <$> getFileStatus + , narReadLink = readSymbolicLink + } + + +isExecutable :: Functor m => NarEffects m -> FilePath -> m IsExecutable +isExecutable effs fp = + bool NonExecutable Executable . executable <$> narGetPerms effs fp diff --git a/src/System/Nix/Path.hs b/src/System/Nix/Path.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Path.hs @@ -0,0 +1,128 @@ +{-| +Description : Types and effects for interacting with the Nix store. +Maintainer : Shea Levy +-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module System.Nix.Path + ( FilePathPart(..) + , PathHashAlgo + , Path(..) + , pathToText + , PathSet + , SubstitutablePathInfo(..) + , ValidPathInfo(..) + , PathName(..) + , filePathPart + , pathName + , Roots + ) where + +import System.Nix.Hash (Digest(..), + HashAlgorithm(Truncated, SHA256)) +import System.Nix.Internal.Hash +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.Hashable (Hashable (..), hashPtrWithSalt) +import Data.HashMap.Strict (HashMap) +import Data.HashSet (HashSet) +import Data.Map.Strict (Map) +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import System.IO.Unsafe (unsafeDupablePerformIO) +import Text.Regex.Base.RegexLike (makeRegex, matchTest) +import Text.Regex.TDFA.Text (Regex) + +-- | The hash algorithm used for store path hashes. +type PathHashAlgo = Truncated 20 SHA256 + + +-- | The name portion of a Nix path. +-- +-- Must be composed of a-z, A-Z, 0-9, +, -, ., _, ?, and =, can't +-- start with a ., and must have at least one character. +newtype PathName = PathName + { pathNameContents :: Text -- ^ The contents of the path name + } deriving (Eq, Ord, Show, Hashable) + +-- | A regular expression for matching a valid 'PathName' +nameRegex :: Regex +nameRegex = + makeRegex ("[a-zA-Z0-9\\+\\-\\_\\?\\=][a-zA-Z0-9\\+\\-\\.\\_\\?\\=]*" :: String) + +-- | Construct a 'PathName', assuming the provided contents are valid. +pathName :: Text -> Maybe PathName +pathName n = case matchTest nameRegex n of + True -> Just $ PathName n + False -> Nothing + +-- | A path in a store. +data Path = Path !(Digest PathHashAlgo) !PathName + deriving (Eq, Ord, Show) + +pathToText :: Text -> Path -> Text +pathToText storeDir (Path h nm) = storeDir <> "/" <> encodeBase32 h <> "-" <> pathNameContents nm + +type PathSet = HashSet Path + +-- | Information about substitutes for a 'Path'. +data SubstitutablePathInfo = SubstitutablePathInfo + { -- | The .drv which led to this 'Path'. + deriver :: !(Maybe Path) + , -- | The references of the 'Path' + references :: !PathSet + , -- | The (likely compressed) size of the download of this 'Path'. + downloadSize :: !Integer + , -- | The size of the uncompressed NAR serialization of this + -- 'Path'. + narSize :: !Integer + } deriving (Eq, Ord, Show) + +-- | Information about @Path@ +data ValidPathInfo = ValidPathInfo + { -- | Path itself + path :: !Path + , -- | The .drv which led to this 'Path'. + deriverVP :: !(Maybe Path) + , -- | NAR hash + narHash :: !Text + , -- | The references of the 'Path' + referencesVP :: !PathSet + , -- | Registration time should be time_t + registrationTime :: !Integer + , -- | The size of the uncompressed NAR serialization of this + -- 'Path'. + narSizeVP :: !Integer + , -- | Whether the path is ultimately trusted, that is, it's a + -- derivation output that was built locally. + ultimate :: !Bool + , -- | Signatures + sigs :: ![Text] + , -- | Content-addressed + -- Store path is computed from a cryptographic hash + -- of the contents of the path, plus some other bits of data like + -- the "name" part of the path. + -- + -- ‘ca’ has one of the following forms: + -- * ‘text:sha256:’ (paths by makeTextPath() / addTextToStore()) + -- * ‘fixed:::’ (paths by makeFixedOutputPath() / addToStore()) + ca :: !Text + } deriving (Eq, Ord, Show) + +-- | A valid filename or directory name +newtype FilePathPart = FilePathPart { unFilePathPart :: BSC.ByteString } + deriving (Eq, Ord, Show) + +-- | Construct FilePathPart from Text by checking that there +-- are no '/' or '\\NUL' characters +filePathPart :: BSC.ByteString -> Maybe FilePathPart +filePathPart p = case BSC.any (`elem` ['/', '\NUL']) p of + False -> Just $ FilePathPart p + True -> Nothing + +type Roots = Map Path Path + +instance Hashable Path where + hashWithSalt s (Path hash name) = s `hashWithSalt` hash `hashWithSalt` name diff --git a/src/System/Nix/ReadonlyStore.hs b/src/System/Nix/ReadonlyStore.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/ReadonlyStore.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module System.Nix.ReadonlyStore where + +import Data.ByteString (ByteString) +import Data.ByteString.Base16 as Base16 +import qualified Data.HashSet as HS +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding +import System.Nix.Hash +import System.Nix.Path + +makeStorePath :: Text -> Text -> Digest 'SHA256 -> Text -> Path +makeStorePath storeDir ty h nm = Path storeHash (PathName nm) + where + s = T.intercalate ":" + [ ty + , algoName @'SHA256 + , encodeBase16 h + , storeDir + , nm + ] + storeHash = hash $ encodeUtf8 s + +makeTextPath :: Text -> Text -> Digest 'SHA256 -> PathSet -> Path +makeTextPath storeDir nm h refs = makeStorePath storeDir ty h nm + where + ty = T.intercalate ":" ("text" : map (pathToText storeDir) (HS.toList refs)) + +computeStorePathForText :: Text -> Text -> ByteString -> PathSet -> Path +computeStorePathForText storeDir nm s refs = makeTextPath storeDir nm (hash s) refs diff --git a/src/System/Nix/Store.hs b/src/System/Nix/Store.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store.hs @@ -0,0 +1,66 @@ +{-| +Description : Types and effects for interacting with the Nix store. +Maintainer : Shea Levy +-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module System.Nix.Store + ( PathName, pathNameContents, pathName + , PathHashAlgo, Path(..) + , StoreEffects(..) + , SubstitutablePathInfo(..) + ) where + +import qualified Data.ByteString.Lazy as BS +import Data.Text (Text) +import Text.Regex.Base.RegexLike (makeRegex, matchTest) +import Text.Regex.TDFA.Text (Regex) +import Data.Hashable (Hashable(..), hashPtrWithSalt) +import Data.HashSet (HashSet) +import Data.HashMap.Strict (HashMap) +import System.IO.Unsafe (unsafeDupablePerformIO) + +import System.Nix.Hash (Digest) +import System.Nix.Path +import System.Nix.Nar + + +-- | Interactions with the Nix store. +-- +-- @rootedPath@: A path plus a witness to the fact that the path is +-- reachable from a root whose liftime is at least as long as the +-- @rootedPath@ reference itself, when the implementation supports +-- this. +-- +-- @validPath@: A @rootedPath@ plus a witness to the fact that the +-- path is valid. On implementations that support temporary roots, +-- this implies that the path will remain valid so long as the +-- reference is held. +-- +-- @m@: The monad the effects operate in. +data StoreEffects rootedPath validPath m = + StoreEffects + { -- | Project out the underlying 'Path' from a 'rootedPath' + fromRootedPath :: !(rootedPath -> Path) + , -- | Project out the underlying 'rootedPath' from a 'validPath' + fromValidPath :: !(validPath -> rootedPath) + , -- | Which of the given paths are valid? + validPaths :: !(HashSet rootedPath -> m (HashSet validPath)) + , -- | Get the paths that refer to a given path. + referrers :: !(validPath -> m (HashSet Path)) + , -- | Get a root to the 'Path'. + rootedPath :: !(Path -> m rootedPath) + , -- | Get information about substituters of a set of 'Path's + substitutablePathInfos :: + !(HashSet Path -> m (HashMap Path SubstitutablePathInfo)) + , -- | Get the currently valid derivers of a 'Path'. + validDerivers :: !(Path -> m (HashSet Path)) + , -- | Get the outputs of the derivation at a 'Path'. + derivationOutputs :: !(validPath -> m (HashSet Path)) + , -- | Get the output names of the derivation at a 'Path'. + derivationOutputNames :: !(validPath -> m (HashSet Text)) + , -- | Get a full 'Path' corresponding to a given 'Digest'. + pathFromHashPart :: !(Digest PathHashAlgo -> m Path) + , -- | Add a non-nar file to the store + addFile :: !(BS.ByteString -> m validPath) + } diff --git a/src/System/Nix/Util.hs b/src/System/Nix/Util.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Util.hs @@ -0,0 +1,48 @@ +{-| +Description : Utilities for packing stuff +Maintainer : srk +|-} +module System.Nix.Util where + +import Control.Monad +import Data.Binary.Get +import Data.Binary.Put +import qualified Data.ByteString.Lazy as LBS + +putInt :: Integral a => a -> Put +putInt = putWord64le . fromIntegral + +getInt :: Integral a => Get a +getInt = fromIntegral <$> getWord64le + +-- length prefixed string packing with padding to 8 bytes +putByteStringLen :: LBS.ByteString -> Put +putByteStringLen x = do + putInt $ fromIntegral $ len + putLazyByteString x + when (len `mod` 8 /= 0) $ + pad $ fromIntegral $ 8 - (len `mod` 8) + where len = LBS.length x + pad x = forM_ (take x $ cycle [0]) putWord8 + +putByteStrings :: Foldable t => t LBS.ByteString -> Put +putByteStrings xs = do + putInt $ fromIntegral $ length xs + mapM_ putByteStringLen xs + +getByteStringLen :: Get LBS.ByteString +getByteStringLen = do + len <- getInt + st <- getLazyByteString len + when (len `mod` 8 /= 0) $ do + pads <- unpad $ fromIntegral $ 8 - (len `mod` 8) + unless (all (==0) pads) $ fail $ "No zeroes" ++ show (st, len, pads) + return st + where unpad x = sequence $ replicate x getWord8 + +getByteStrings :: Get [LBS.ByteString] +getByteStrings = do + count <- getInt + res <- sequence $ replicate count getByteStringLen + return res + 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/Hash.hs b/tests/Hash.hs new file mode 100644 --- /dev/null +++ b/tests/Hash.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Hash where + +import Control.Monad.IO.Class (liftIO) +import Control.Exception (bracket) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64.Lazy as B64 +import qualified Data.ByteString.Lazy as BSL +import Data.Monoid ((<>)) +import qualified Data.Text as T +import System.Directory (removeFile) +import System.IO.Temp (withSystemTempFile, writeSystemTempFile) +import qualified System.IO as IO -- (hGetContents, hPutStr, openFile) +import qualified System.Process as P +import Test.Tasty as T +import Test.Tasty.Hspec +import qualified Test.Tasty.HUnit as HU +import Test.Tasty.QuickCheck +import Text.Read (readMaybe) + +import System.Nix.Hash +import System.Nix.Path +import NarFormat -- TODO: Move the fixtures into a common module + +spec_hash :: Spec +spec_hash = do + + describe "hashing parity with nix-store" $ do + + it "produces (base32 . sha256) of \"nix-output:foo\" the same as Nix does at the moment for placeholder \"foo\"" $ + shouldBe (encodeBase32 (hash @SHA256 "nix-output:foo")) + "1x0ymrsy7yr7i9wdsqy9khmzc1yy7nvxw6rdp72yzn50285s67j5" + + it "produces (base32 . sha1) of \"Hello World\" the same as the thesis" $ + shouldBe (encodeBase32 (hash @SHA1 "Hello World")) + "s23c9fs0v32pf6bhmcph5rbqsyl5ak8a" + + -- The example in question: + -- https://nixos.org/nixos/nix-pills/nix-store-paths.html + it "produces same base32 as nix pill flat file example" $ do + let exampleStr = + "source:sha256:2bfef67de873c54551d884fdab3055d84d573e654efa79db3" + <> "c0d7b98883f9ee3:/nix/store:myfile" + shouldBe (encodeBase32 @PathHashAlgo (hash exampleStr)) + "xv2iccirbrvklck36f1g7vldn5v58vck" diff --git a/tests/NarFormat.hs b/tests/NarFormat.hs new file mode 100644 --- /dev/null +++ b/tests/NarFormat.hs @@ -0,0 +1,366 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module NarFormat where + +import Control.Applicative ((<|>)) +import Control.Concurrent (threadDelay) +import Control.Exception (SomeException, bracket, try) +import Control.Monad (replicateM) +import Control.Monad.IO.Class (liftIO) +import Data.Binary (put) +import Data.Binary.Get (Get (..), runGet) +import Data.Binary.Put (Put (..), runPut) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64.Lazy as B64 +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSLC +import Data.Int +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, isJust) +import qualified Data.Text as T +import GHC.Stats (getRTSStats, max_live_bytes) +import System.Directory (removeFile) +import System.Environment (getEnv) +import qualified System.Process as P +import Test.Tasty as T +import Test.Tasty.Hspec +import qualified Test.Tasty.HUnit as HU +import Test.Tasty.QuickCheck +import Text.Read (readMaybe) + +import System.Nix.Nar +import System.Nix.Path + + + +spec_narEncoding :: Spec +spec_narEncoding = do + + -- For a Haskell embedded Nar, check that (decode . encode === id) + let roundTrip n = runGet getNar (runPut $ putNar n) `shouldBe` n + + -- For a Haskell embedded Nar, check that encoding it gives + -- the same bytestring as `nix-store --dump` + let encEqualsNixStore n b = runPut (putNar n) `shouldBe` b + + + describe "parser-roundtrip" $ do + it "roundtrips regular" $ do + roundTrip (Nar sampleRegular) + + it "roundtrips regular 2" $ do + roundTrip (Nar sampleRegular') + + it "roundtrips executable" $ do + roundTrip (Nar sampleExecutable) + + it "roundtrips symlink" $ do + roundTrip (Nar sampleSymLink) + + it "roundtrips directory" $ do + roundTrip (Nar sampleDirectory) + + + describe "matches-nix-store fixture" $ do + it "matches regular" $ do + encEqualsNixStore (Nar sampleRegular) sampleRegularBaseline + + it "matches regular'" $ + encEqualsNixStore (Nar sampleRegular') sampleRegular'Baseline + + it "matches executable" $ + encEqualsNixStore (Nar sampleExecutable) sampleExecutableBaseline + + it "matches symlink" $ + encEqualsNixStore (Nar sampleSymLink) sampleSymLinkBaseline + + it "matches directory" $ do + encEqualsNixStore (Nar sampleDirectory) sampleDirectoryBaseline + +unit_nixStoreRegular :: HU.Assertion +unit_nixStoreRegular = filesystemNixStore "regular" (Nar sampleRegular) + +unit_nixStoreDirectory :: HU.Assertion +unit_nixStoreDirectory = filesystemNixStore "directory" (Nar sampleDirectory) + +unit_nixStoreDirectory' :: HU.Assertion +unit_nixStoreDirectory' = filesystemNixStore "directory'" (Nar sampleDirectory') + +unit_nixStoreBigFile :: HU.Assertion +unit_nixStoreBigFile = getBigFileSize >>= \sz -> + filesystemNixStore "bigfile'" (Nar $ sampleLargeFile sz) + +unit_nixStoreBigDir :: HU.Assertion +unit_nixStoreBigDir = getBigFileSize >>= \sz -> + filesystemNixStore "bigfile'" (Nar $ sampleLargeDir sz) + +prop_narEncodingArbitrary :: Nar -> Property +prop_narEncodingArbitrary n = runGet getNar (runPut $ putNar n) === n + +unit_packSelfSrcDir :: HU.Assertion +unit_packSelfSrcDir = do + ver <- try (P.readProcess "nix-store" ["--version"] "") + case ver of + Left (e :: SomeException) -> print "No nix-store on system" + Right _ -> do + hnixNar <- runPut . put <$> localPackNar narEffectsIO "src" + nixStoreNar <- getNixStoreDump "src" + HU.assertEqual + "src dir serializes the same between hnix-store and nix-store" + hnixNar + nixStoreNar + +unit_streamLargeFileToNar :: HU.Assertion +unit_streamLargeFileToNar = + bracket (getBigFileSize >>= makeBigFile) (const rmFiles) $ \_ -> do + nar <- localPackNar narEffectsIO bigFileName + BSL.writeFile narFileName . runPut . put $ nar + assertBoundedMemory + where + bigFileName = "bigFile.bin" + narFileName = "bigFile.nar" + makeBigFile = \sz -> BSL.writeFile bigFileName + (BSL.take sz $ BSL.cycle "Lorem ipsum") + rmFiles = removeFile bigFileName >> removeFile narFileName + + +-- **************** Utilities ************************ + +-- | Generate the ground-truth encoding on the fly with +-- `nix-store --dump`, rather than generating fixtures +-- beforehand +filesystemNixStore :: String -> Nar -> IO () +filesystemNixStore testErrorName n = do + + ver <- try (P.readProcess "nix-store" ["--version"] "") + case ver of + -- Left is not an error - testing machine simply doesn't have + -- `nix-store` executable, so pass + Left (e :: SomeException) -> print "No nix-store on system" + Right _ -> + bracket (return ()) (\_ -> P.runCommand "rm -rf testfile nixstorenar.nar hnix.nar") $ \_ -> do + + -- stream nar contents to unpacked file(s) + localUnpackNar narEffectsIO "testfile" n + + -- nix-store converts those files to nar + getNixStoreDump "testfile" >>= BSL.writeFile "nixstorenar.nar" + + -- hnix converts those files to nar + localPackNar narEffectsIO "testfile" >>= BSL.writeFile "hnix.nar" . runPut . putNar + + diffResult <- P.readProcess "diff" ["nixstorenar.nar", "hnix.nar"] "" + + assertBoundedMemory + HU.assertEqual testErrorName diffResult "" + + +-- | Assert that GHC uses less than 100M memory at peak +assertBoundedMemory :: IO () +assertBoundedMemory = do +#ifdef BOUNDED_MEMORY + bytes <- max_live_bytes <$> getRTSStats + bytes < 100 * 1000 * 1000 `shouldBe` True +#else + return () +#endif + + +-- | 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]] + ++ [ + (FilePathPart "d", Directory $ Map.fromList + [ (FilePathPart (BSC.pack $ "df" ++ show n) + , Regular NonExecutable 10000 (BSL.take 10000 (BSL.cycle "subhi "))) + | n <- [1..100]] + ) + ] + +-- * For each sample above, feed it into `nix-store --dump`, +-- and base64 encode the resulting NAR binary. This lets us +-- check our Haskell NAR generator against `nix-store` + +-- "hi" file turned to a NAR with `nix-store --dump`, Base64 encoded +sampleRegularBaseline :: BSL.ByteString +sampleRegularBaseline = B64.decodeLenient $ BSL.concat + ["DQAAAAAAAABuaXgtYXJjaGl2ZS0xAAAAAQAAAAAAAAAoAAAAAAA" + ,"AAAQAAAAAAAAAdHlwZQAAAAAHAAAAAAAAAHJlZ3VsYXIACAAAAA" + ,"AAAABjb250ZW50cwMAAAAAAAAAaGkKAAAAAAABAAAAAAAAACkAA" + ,"AAAAAAA" + ] + +sampleRegular'Baseline :: BSL.ByteString +sampleRegular'Baseline = B64.decodeLenient $ BSL.concat + ["DQAAAAAAAABuaXgtYXJjaGl2ZS0xAAAAAQAAAAAAAAAoAAAAAAA" + ,"AAAQAAAAAAAAAdHlwZQAAAAAHAAAAAAAAAHJlZ3VsYXIACAAAAA" + ,"AAAABjb250ZW50c0AAAAAAAAAAI2luY2x1ZGUgPHN0ZGlvLmg+C" + ,"gppbnQgbWFpbihpbnQgYXJnYywgY2hhciAqYXJndltdKXsgZXhp" + ,"dCAwOyB9CgEAAAAAAAAAKQAAAAAAAAA=" + ] + +sampleExecutableBaseline :: BSL.ByteString +sampleExecutableBaseline = B64.decodeLenient $ BSL.concat + ["DQAAAAAAAABuaXgtYXJjaGl2ZS0xAAAAAQAAAAAAAAAoAAAAAAA" + ,"AAAQAAAAAAAAAdHlwZQAAAAAHAAAAAAAAAHJlZ3VsYXIACgAAAA" + ,"AAAABleGVjdXRhYmxlAAAAAAAAAAAAAAAAAAAIAAAAAAAAAGNvb" + ,"nRlbnRzIgAAAAAAAAAjIS9iaW4vYmFzaAoKZ2NjIC1vIGhlbGxv" + ,"IGhlbGxvLmMKAAAAAAAAAQAAAAAAAAApAAAAAAAAAA==" + ] + +sampleSymLinkBaseline :: BSL.ByteString +sampleSymLinkBaseline = B64.decodeLenient $ BSL.concat + ["DQAAAAAAAABuaXgtYXJjaGl2ZS0xAAAAAQAAAAAAAAAoAAAAAAA" + ,"AAAQAAAAAAAAAdHlwZQAAAAAHAAAAAAAAAHN5bWxpbmsABgAAAA" + ,"AAAAB0YXJnZXQAAAcAAAAAAAAAaGVsbG8uYwABAAAAAAAAACkAA" + ,"AAAAAAA" + ] + +sampleDirectoryBaseline :: BSL.ByteString +sampleDirectoryBaseline = B64.decodeLenient $ BSL.concat + ["DQAAAAAAAABuaXgtYXJjaGl2ZS0xAAAAAQAAAAAAAAAoAAAAAAA" + ,"AAAQAAAAAAAAAdHlwZQAAAAAJAAAAAAAAAGRpcmVjdG9yeQAAAA" + ,"AAAAAFAAAAAAAAAGVudHJ5AAAAAQAAAAAAAAAoAAAAAAAAAAQAA" + ,"AAAAAAAbmFtZQAAAAAIAAAAAAAAAGJ1aWxkLnNoBAAAAAAAAABu" + ,"b2RlAAAAAAEAAAAAAAAAKAAAAAAAAAAEAAAAAAAAAHR5cGUAAAA" + ,"ABwAAAAAAAAByZWd1bGFyAAoAAAAAAAAAZXhlY3V0YWJsZQAAAA" + ,"AAAAAAAAAAAAAACAAAAAAAAABjb250ZW50cyIAAAAAAAAAIyEvY" + ,"mluL2Jhc2gKCmdjYyAtbyBoZWxsbyBoZWxsby5jCgAAAAAAAAEA" + ,"AAAAAAAAKQAAAAAAAAABAAAAAAAAACkAAAAAAAAABQAAAAAAAAB" + ,"lbnRyeQAAAAEAAAAAAAAAKAAAAAAAAAAEAAAAAAAAAG5hbWUAAA" + ,"AABwAAAAAAAABoZWxsby5jAAQAAAAAAAAAbm9kZQAAAAABAAAAA" + ,"AAAACgAAAAAAAAABAAAAAAAAAB0eXBlAAAAAAcAAAAAAAAAcmVn" + ,"dWxhcgAIAAAAAAAAAGNvbnRlbnRzQAAAAAAAAAAjaW5jbHVkZSA" + ,"8c3RkaW8uaD4KCmludCBtYWluKGludCBhcmdjLCBjaGFyICphcm" + ,"d2W10peyBleGl0IDA7IH0KAQAAAAAAAAApAAAAAAAAAAEAAAAAA" + ,"AAAKQAAAAAAAAAFAAAAAAAAAGVudHJ5AAAAAQAAAAAAAAAoAAAA" + ,"AAAAAAQAAAAAAAAAbmFtZQAAAAAEAAAAAAAAAGhpLmMAAAAABAA" + ,"AAAAAAABub2RlAAAAAAEAAAAAAAAAKAAAAAAAAAAEAAAAAAAAAH" + ,"R5cGUAAAAABwAAAAAAAABzeW1saW5rAAYAAAAAAAAAdGFyZ2V0A" + ,"AAHAAAAAAAAAGhlbGxvLmMAAQAAAAAAAAApAAAAAAAAAAEAAAAA" + ,"AAAAKQAAAAAAAAABAAAAAAAAACkAAAAAAAAA" + ] + + +-- | Control testcase sizes (bytes) by env variable +getBigFileSize :: IO Int64 +getBigFileSize = fromMaybe 1000000 . readMaybe <$> (getEnv "HNIX_BIG_FILE_SIZE" <|> pure "") + + +-- | Add a link to a FileSystemObject. This is useful +-- when creating Arbitrary FileSystemObjects. It +-- isn't implemented yet +mkLink :: + FilePath -- ^ Target + -> FilePath -- ^ Link + -> FileSystemObject -- ^ FileSystemObject to add link to + -> FileSystemObject +mkLink = undefined -- TODO + + +instance Arbitrary Nar where + arbitrary = Nar <$> resize 10 arbitrary + +instance Arbitrary FileSystemObject where + -- To build an arbitrary Nar, + arbitrary = do + n <- getSize + if n < 2 + then arbFile + else arbDirectory n + + where + + arbFile :: Gen FileSystemObject + arbFile = do + Positive fSize <- arbitrary + Regular + <$> elements [NonExecutable, Executable] + <*> pure (fromIntegral fSize) + <*> oneof [ + fmap (BSL.take fSize . BSL.cycle . BSL.pack . getNonEmpty) arbitrary , -- Binary File + fmap (BSL.take fSize . BSL.cycle . BSLC.pack . getNonEmpty) arbitrary -- ASCII File + ] + + arbName :: Gen FilePathPart + arbName = fmap (FilePathPart . BS.pack . fmap (fromIntegral . fromEnum)) $ do + Positive n <- arbitrary + replicateM n (elements $ ['a'..'z'] ++ ['0'..'9']) + + arbDirectory :: Int -> Gen FileSystemObject + arbDirectory n = fmap (Directory . Map.fromList) $ replicateM n $ do + nm <- arbName + f <- oneof [arbFile, arbDirectory (n `div` 2)] + return (nm,f)