diff --git a/.ghcid b/.ghcid new file mode 100644 index 0000000..50b105c --- /dev/null +++ b/.ghcid @@ -0,0 +1 @@ +--command="cabal new-repl test" diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml new file mode 100644 index 0000000..1d8e914 --- /dev/null +++ b/.github/workflows/ci.yaml @@ -0,0 +1,37 @@ +name: CI +on: + pull_request: + push: + branches: + - master + +jobs: + build-test-check: + matrix: + os: + - ubuntu-latest + # TODO: check more OS? + compiler: + - "ghc802" + - "ghc822" + - "ghc844" + - "ghc865" + - "ghc883" + - "ghc8101" + + runs-on: "${{ matrix.os }}" + steps: + - name: Checkout repository + uses: actions/checkout@v2.3.4 + + - name: Install Nix + uses: cachix/install-nix-action@v12 + + - name: Setup cabal cache + uses: actions/cache@v1 + with: + path: "~/.cabal" + key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('kesha.cabal') }} + + - name: Run ci.sh + run: "nix-shell --arg dev false --run ./ci.sh" diff --git a/.gitignore b/.gitignore index a459a4e..40b44e6 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,4 @@ dist-newstyle/ dist/ .stack-work/ result +cabal.project.freeze diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 1c0ab9c..0000000 --- a/.travis.yml +++ /dev/null @@ -1,3 +0,0 @@ -language: nix -nix: 2.2.2 -script: ci.sh diff --git a/ci.sh b/ci.sh index e398bcd..319ea13 100755 --- a/ci.sh +++ b/ci.sh @@ -1,5 +1,4 @@ -#!/usr/bin/env nix-shell -#! nix-shell -i bash +#!/usr/bin/env bash set -euo pipefail shopt -s inherit_errexit diff --git a/kesha.cabal b/kesha.cabal index f92554f..abc2bbf 100644 --- a/kesha.cabal +++ b/kesha.cabal @@ -1,25 +1,28 @@ -cabal-version: >=1.10 -build-type: Simple +cabal-version: >= 1.10 name: kesha -version: 0.2.0 -synopsis: Compute the cryptographic hash of any path -description: - A Haskell library and executable for computing the cryptographic hash of any path. - +version: 0.1.0 +synopsis: Haskell implementation of nix-hash +description: Compute the cryptographic hash of a path, à la . homepage: https://github.com/jmackie/kesha bug-reports: https://github.com/jmackie/kesha/issues license: MIT license-file: LICENSE author: Jordan Mackie -maintainer: jmackie@protonmail.com +maintainer: contact@jmackie.dev copyright: (c) 2020 Jordan Mackie category: System +build-type: Simple extra-source-files: README.md tested-with: - GHC ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.3 + GHC == 8.0.2, + GHC == 8.2.2, + GHC == 8.4.4, + GHC == 8.6.5, + GHC == 8.8.3, + GHC == 8.10.1 source-repository head type: git @@ -28,7 +31,11 @@ source-repository head library default-language: Haskell2010 hs-source-dirs: src - ghc-options: -Wall + ghc-options: + -Weverything + -fno-warn-missing-import-lists + -fno-warn-safe + -fno-warn-unsafe exposed-modules: Kesha Kesha.NAR @@ -37,34 +44,43 @@ library -- >= 8.2.2 && < 8.9 base >= 4.10.1 && < 4.14, - -- boot libraries - binary, - bytestring, - containers, + -- core libraries + binary >= 0.8.6 && < 0.9, + bytestring >= 0.10.8 && < 0.11, + containers >= 0.6.0 && < 0.7, + filepath >= 1.4.2 && < 1.5, + text >= 1.2.3 && < 1.3, -- 1.3.1.0 introduced `getSymbolicLinkTarget` - directory >= 1.3.1, - filepath, - text, + directory >= 1.3.1 && < 1.4, - cryptohash-sha256 + cryptohash-md5 >= 0.11.100 && < 0.12, + cryptohash-sha1 >= 0.11.100 && < 0.12, + cryptohash-sha256 >= 0.11.101 && < 0.12 test-suite test default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: test - ghc-options: -Wall -threaded -rtsopts + ghc-options: + -Weverything + -fno-warn-missing-import-lists + -fno-warn-safe + -fno-warn-unsafe + + -threaded + -rtsopts build-depends: kesha, - base >= 4.10.1 && < 4.14, - + base, bytestring, containers, - directory >= 1.3.1, + directory, filepath, - process, + -- Test dependencies + process, hspec, QuickCheck, temporary diff --git a/shell.nix b/shell.nix index bce3a75..523b173 100644 --- a/shell.nix +++ b/shell.nix @@ -1,19 +1,22 @@ +{ compiler ? "ghc865", dev ? true # Include tools useful for development? +}: let - pinnedPkgs = - # 2020-05-17T11:55:13+02:00 - let rev = "85d6f3bcd9cbcc52c4a307d2ef5116dab4b41641"; - in import (builtins.fetchTarball { - name = "nixpkgs-${rev}"; - url = "https://github.com/nixos/nixpkgs/archive/${rev}.tar.gz"; - sha256 = "10jxpwq47clbj047jh5zn20hqmwpc821ac8zljgpayk0sk5p0mwv"; - }) { }; -in { pkgs ? pinnedPkgs, compiler ? "ghc865" }: -pkgs.mkShell { - buildInputs = [ - pkgs.haskell.packages."${compiler}".ghc - pkgs.cabal-install - pkgs.ormolu - pkgs.hlint - ]; -} + pkgs = let rev = "7d75a77954aaa61fa0b2931b354b61cc0aa4a60a"; + in import (builtins.fetchTarball { + name = "nixpkgs-${rev}"; + url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz"; + sha256 = "0qf3rp0jqgipjzz51ws8nwxiaiglz9jf7hc6d7x75ddbp0wlfjmg"; + }) { overlays = [ (self: super: { llvm_39 = super.llvm_5; }) ]; }; + + old-ghc-nix = let rev = "674d459c7376af6641c94e91cd7d36214661b481"; + in import (builtins.fetchTarball { + name = "old-ghc-nix-${rev}"; + url = "https://github.com/mpickering/old-ghc-nix/archive/${rev}.tar.gz"; + sha256 = "1w3d5dm9v7ms1s7xp39wncgwvh3kclp2bkdqa2kxn3x5dyayfm61"; + }) { inherit pkgs; }; +in pkgs.mkShell { + buildInputs = + [ old-ghc-nix."${compiler}" pkgs.cabal-install pkgs.ormolu pkgs.hlint ] + ++ (if dev then [ pkgs.ghcid ] else [ ]); +} diff --git a/src/Kesha.hs b/src/Kesha.hs index 8a27bf9..f73854d 100644 --- a/src/Kesha.hs +++ b/src/Kesha.hs @@ -1,17 +1,28 @@ {-# LANGUAGE OverloadedStrings #-} +-- | +-- Module: Kesha +-- Copyright: (c) 2020 Jordan Mackie +-- License: MIT +-- Maintainer: Jordan Mackie +-- Stability: experimental +-- Portability: portable +-- +-- An implementation of @@. module Kesha ( hash, hashWith, - Opts (..), - defaultOpts, + HashOptions (..), + defaultHashOptions, HashAlgo (..), HashRepr (..), ) where +import qualified Crypto.Hash.MD5 as MD5 +import qualified Crypto.Hash.SHA1 as SHA1 import qualified Crypto.Hash.SHA256 as SHA256 -import Data.Bits ((.&.), (.|.), shiftL, shiftR) +import Data.Bits (shiftL, shiftR, (.&.), (.|.)) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as ASCII import qualified Data.Char as Char @@ -22,62 +33,95 @@ import qualified Kesha.NAR as NAR import Prelude hiding ((!!)) -- | --- Compute the cryptographic hash of a path using the 'defaultOpts'. +-- Compute the cryptographic hash of a path using the 'defaultHashOptions'. -- -- The output of @'hash' path@ should be consistent with that of --- @nix-hash --type sha256 --base32 path@ (invoked at the command line). -hash :: FilePath -> IO (Either String BS.ByteString) -hash = hashWith defaultOpts +-- @nix-hash --type sha256 --base32 path@. +hash :: FilePath -> IO (Either NAR.PackError BS.ByteString) +hash = hashWith defaultHashOptions -- | --- Compute the cryptographic hash of a path using the given 'Opts'. -hashWith :: Opts -> FilePath -> IO (Either String BS.ByteString) +-- Compute the cryptographic hash of a path using the given 'HashOptions'. +hashWith :: HashOptions -> FilePath -> IO (Either NAR.PackError BS.ByteString) hashWith opts path = fmap (printNar (hashAlgo opts) (hashRepr opts)) <$> NAR.localPack path -- | -- Hashing options. -data Opts - = Opts - { -- | cryptographic hash algorithm to use - hashAlgo :: HashAlgo, - -- | how to print the hash - hashRepr :: HashRepr - } +data HashOptions = HashOptions + { -- | cryptographic hash algorithm to use + hashAlgo :: HashAlgo, + -- | how to print the hash + hashRepr :: HashRepr + } -- | -- Default hashing options. -- -- These are the default options used by most of the Nix tooling (e.g. -- @nix-prefetch-git@). -defaultOpts :: Opts -defaultOpts = Opts SHA256 Base32 +defaultHashOptions :: HashOptions +defaultHashOptions = HashOptions SHA256 Base32 -- | -- Available hash algorithms. data HashAlgo - = SHA256 + = MD5 + | SHA1 + | SHA256 -- | -- Printable hash representations. data HashRepr - = Base32 + = Base16 + | Base32 printNar :: HashAlgo -> HashRepr -> NAR.NAR -> BS.ByteString -printNar SHA256 Base32 = +printNar algo repr = ASCII.map Char.toLower - . printHash32 SHA256 - . SHA256.hash + . ( case repr of + Base16 -> printHash16 algo + Base32 -> printHash32 algo + ) + . ( case algo of + MD5 -> MD5.hash + SHA1 -> SHA1.hash + SHA256 -> SHA256.hash + ) . NAR.dump +-- https://github.com/NixOS/nix/blob/master/src/libutil/hash.cc +printHash16 :: HashAlgo -> BS.ByteString -> BS.ByteString +printHash16 algo rawHash = + ASCII.pack $ + foldMap + ( \i -> + [ base16Chars !! fromIntegral (BS.index rawHash i `shiftR` 4), + base16Chars !! fromIntegral (BS.index rawHash i .&. 15) + ] + ) + [0 .. hashSize - 1] + where + hashSize :: Int + hashSize = hashSizeForAlgo algo + + base16Chars :: Seq.Seq Char + base16Chars = "0123456789abcdef" + -- https://github.com/NixOS/nix/blob/master/src/libutil/hash.cc printHash32 :: HashAlgo -> BS.ByteString -> BS.ByteString printHash32 algo rawHash = go (len - 1) "" where hashSize :: Int hashSize = hashSizeForAlgo algo + + -- omitted: E O U T + base32Chars :: Seq.Seq Char + base32Chars = Seq.fromList "0123456789abcdfghijklmnpqrsvwxyz" + len :: Int len = (hashSize * 8 - 1) `div` 5 + 1 + go :: Int -> BS.ByteString -> BS.ByteString go n accum | n < 0 = accum @@ -85,7 +129,7 @@ printHash32 algo rawHash = go (len - 1) "" go (pred n) $ ASCII.snoc accum (base32Chars !! (fromIntegral c .&. 0x1f)) where - b , i, j :: Int + b, i, j :: Int b = n * 5 i = b `div` 8 j = b `mod` 8 @@ -93,16 +137,17 @@ printHash32 algo rawHash = go (len - 1) "" c = ((bytes !! i) `shiftR` j) .|. (if i >= (hashSize - 1) then 0 else (bytes !! (i + 1)) `shiftL` (8 - j)) + bytes :: Seq.Seq Word8 bytes = Seq.fromList (BS.unpack rawHash) - (!!) :: Seq.Seq a -> Int -> a - (!!) xs i = fromJust (Seq.lookup i xs) - infixl 9 !! -- https://github.com/NixOS/nix/blob/master/src/libutil/hash.hh hashSizeForAlgo :: HashAlgo -> Int +hashSizeForAlgo MD5 = 16 +hashSizeForAlgo SHA1 = 20 hashSizeForAlgo SHA256 = 32 --- omitted: E O U T -base32Chars :: Seq.Seq Char -base32Chars = Seq.fromList "0123456789abcdfghijklmnpqrsvwxyz" +(!!) :: Seq.Seq a -> Int -> a +(!!) xs i = fromJust (Seq.lookup i xs) + +infixl 9 !! diff --git a/src/Kesha/NAR.hs b/src/Kesha/NAR.hs index bf6ff3e..4a7bbe3 100644 --- a/src/Kesha/NAR.hs +++ b/src/Kesha/NAR.hs @@ -1,17 +1,24 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -- | --- Implementation of the Nix ARchive format (NAR) +-- Module: Kesha.NAR +-- Copyright: (c) 2020 Jordan Mackie +-- License: MIT +-- Maintainer: Jordan Mackie +-- Stability: experimental +-- Portability: portable -- --- https://nixos.org/~eelco/pubs/phd-thesis.pdf +-- An implementation of the (NAR). module Kesha.NAR ( NAR, + PackError (..), localPack, dump, ) where +{- HLINT ignore "Use lambda-case" -} + import Control.Monad (when) import Data.Bifunctor (second) import qualified Data.Binary.Put as Binary @@ -21,8 +28,8 @@ import Data.Foldable (for_, traverse_) import qualified Data.List as List import qualified Data.Map as Map import Data.Semigroup ((<>)) -import qualified Data.Text as Text import Data.Text (Text) +import qualified Data.Text as Text import Data.Text.Encoding (encodeUtf8) import Data.Traversable (for) import qualified System.Directory as Directory @@ -31,20 +38,32 @@ import Prelude -- | -- A packed NAR archive. -newtype NAR = NAR FSO +newtype NAR = NAR {getFSO :: FSO} + +-- | +-- Errors that can be raised when attempting to pack a path into a NAR archive. +data PackError + = -- | + -- Attempted to pack a path that doesn't exist. + FileDoesNotExist FilePath + | -- | + -- Heuristic for detecting the /type/ of path failed. Where /type/ is one: + -- a regular file, a directory, or a symbolic link. + AmbiguousFileType FilePath + deriving (Show, Eq) data FSO - = Regular IsExecutable Size BS.ByteString - | SymLink Utf8FilePath - | Directory (Map.Map PathPiece FSO) + = Regular !IsExecutable !Size !BS.ByteString + | SymLink !UTF8FilePath + | Directory !(Map.Map PathSegment FSO) type IsExecutable = Bool type Size = Int -type Utf8FilePath = Text +type UTF8FilePath = Text -type PathPiece = Text -- shouldn't include '/' or 'NUL' ! +type PathSegment = Text -- shouldn't include '/' or 'NUL' ! data PathType = RegularType @@ -56,16 +75,16 @@ data PathType -- Create a NAR archive for the given path in a local context. -- -- See figure 5.2 of https://nixos.org/~eelco/pubs/phd-thesis.pdf -localPack :: FilePath -> IO (Either String NAR) +localPack :: FilePath -> IO (Either PackError NAR) localPack path = second NAR <$> localPackFSO path -localPackFSO :: FilePath -> IO (Either String FSO) +localPackFSO :: FilePath -> IO (Either PackError FSO) localPackFSO path = - guessPathType path >>= \case + guessPathType path >>= \guess -> case guess of Nothing -> - pure $ Left (path <> ": path doesn't exist") + pure $ Left (FileDoesNotExist path) Just AmbiguousType -> - pure $ Left (path <> ": couldn't work out file type") + pure $ Left (AmbiguousFileType path) Just RegularType -> do isExecutable <- Directory.executable <$> Directory.getPermissions path size <- fromIntegral <$> Directory.getFileSize path @@ -92,10 +111,10 @@ dump :: NAR -> BS.ByteString dump = BSL.toStrict . Binary.runPut . putNAR putNAR :: NAR -> Binary.Put -putNAR (NAR fso) = str "nix-archive-1" <> parens (putFSO fso) +putNAR nar = str "nix-archive-1" <> parens (putFSO (getFSO nar)) where putFSO :: FSO -> Binary.Put - putFSO = \case + putFSO fso = case fso of Regular isExecutable size contents -> do strs ["type", "regular"] when isExecutable $ strs ["executable", ""] @@ -115,18 +134,24 @@ putNAR (NAR fso) = str "nix-archive-1" <> parens (putFSO fso) str (encodeUtf8 name) str "node" parens (putFSO node) + int :: Integral a => a -> Binary.Put int = Binary.putInt64le . fromIntegral + parens :: Binary.Put -> Binary.Put parens m = str "(" >> m >> str ")" + str :: BS.ByteString -> Binary.Put str bs = let len = BS.length bs in int len <> pad len bs + strs :: [BS.ByteString] -> Binary.Put strs = traverse_ str + pad :: Int -> BS.ByteString -> Binary.Put pad n bs = do Binary.putByteString bs Binary.putByteString (BS.replicate (padLen n) 0) + -- Distance to the next multiple of 8 padLen :: Integral a => a -> a padLen n = (8 - n) `mod` 8 diff --git a/test/Main.hs b/test/Main.hs index 3f4b252..2242baa 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Main @@ -10,6 +7,7 @@ where {- HLINT ignore "Redundant do" -} {- HLINT ignore "Use camelCase" -} +{- HLINT ignore "Use lambda-case" -} import Control.Applicative (liftA2) import Control.Monad (when) @@ -37,7 +35,7 @@ import Test.Hspec.QuickCheck ( modifyMaxSuccess, ) import Test.QuickCheck - ( Arbitrary (..), + ( Arbitrary (arbitrary), choose, elements, oneof, @@ -72,62 +70,93 @@ spec :: FilePath -> Spec spec tempDir = do describe "NAR packing" $ do describe "matches the output of `nix-store --dump`" $ do - modifyMaxSuccess (const 20) - $ it "matches for Regular files" - $ property - $ \regular -> - inTempDirectory tempDir "Regular" $ - checkNAR =<< createFSO_Regular regular - modifyMaxSuccess (const 20) - $ it "matches for SymLinks" - $ property - $ \symLink -> do - inTempDirectory tempDir "SymLink" $ - checkNAR =<< createFSO_SymLink symLink - modifyMaxSuccess (const 20) - $ it "matches for Directories" - $ property - $ \directory -> - Temp.withTempDirectory tempDir "Directory" $ \path -> do - createFSO_Directory path directory - checkNAR path + modifyMaxSuccess (const 20) $ + it "matches for Regular files" $ + property $ + \regular -> + inTempDirectory tempDir "Regular" $ + checkNAR =<< createFSO_Regular regular + modifyMaxSuccess (const 20) $ + it "matches for SymLinks" $ + property $ + \symLink -> do + inTempDirectory tempDir "SymLink" $ + checkNAR =<< createFSO_SymLink symLink + modifyMaxSuccess (const 20) $ + it "matches for Directories" $ + property $ + \directory -> + Temp.withTempDirectory tempDir "Directory" $ \path -> do + createFSO_Directory path directory + checkNAR path + describe "Hashing" $ do + describe "matches the output of `nix-hash --type md5" $ do + hashTests 20 (Kesha.HashOptions Kesha.MD5 Kesha.Base16) + + describe "matches the output of `nix-hash --type md5 --base32" $ do + hashTests 20 (Kesha.HashOptions Kesha.MD5 Kesha.Base32) + + describe "matches the output of `nix-hash --type sha1" $ do + hashTests 20 (Kesha.HashOptions Kesha.SHA1 Kesha.Base16) + + describe "matches the output of `nix-hash --type sha1 --base32" $ do + hashTests 20 (Kesha.HashOptions Kesha.SHA1 Kesha.Base32) + + describe "matches the output of `nix-hash --type sha256" $ do + hashTests 20 (Kesha.HashOptions Kesha.SHA256 Kesha.Base16) + describe "matches the output of `nix-hash --type sha256 --base32`" $ do - modifyMaxSuccess (const 20) - $ it "matches for any FSO" - $ property - $ \case - Regular regular -> - inTempDirectory tempDir "Regular" $ - checkHash =<< createFSO_Regular regular - SymLink symLink -> - inTempDirectory tempDir "SymLink" $ - checkHash =<< createFSO_SymLink symLink - Directory directory -> - Temp.withTempDirectory tempDir "Directory" $ \path -> do - createFSO_Directory path directory - checkHash path + hashTests 20 (Kesha.HashOptions Kesha.SHA256 Kesha.Base32) where + hashTests n opts = do + modifyMaxSuccess (const n) $ + it "matches for any FSO" $ + property $ \fso -> case fso of + Regular regular -> + inTempDirectory tempDir "Regular" $ + checkHash opts =<< createFSO_Regular regular + SymLink symLink -> + inTempDirectory tempDir "SymLink" $ + checkHash opts =<< createFSO_SymLink symLink + Directory directory -> + Temp.withTempDirectory tempDir "Directory" $ \path -> do + createFSO_Directory path directory + checkHash opts path + checkNAR :: FilePath -> Expectation checkNAR path = do - result <- liftA2 (,) (nix_store_dump path) (Kesha.NAR.localPack path) + result <- liftA2 (,) (nixStoreDump path) (Kesha.NAR.localPack path) case result of (Right want, Right got) -> want `shouldBe` Kesha.NAR.dump got (Left exitCode, _) -> expectationFailure ("nix-store --dump failed: " <> show exitCode) (_, Left err) -> - expectationFailure ("Kesha.NAR.localPack failed: " <> err) - checkHash :: FilePath -> Expectation - checkHash path = do - result <- liftA2 (,) (nix_hash path) (Kesha.hash path) + expectationFailure ("Kesha.NAR.localPack failed: " <> show err) + + checkHash :: Kesha.HashOptions -> FilePath -> Expectation + checkHash opts path = do + result <- liftA2 (,) (nixHash (optsToArgs opts) path) (Kesha.hashWith opts path) case result of (Right want, Right got) -> want `shouldBe` got (Left exitCode, _) -> expectationFailure ("nix-hash failed: " <> show exitCode) (_, Left err) -> - expectationFailure ("Kesha.hash failed: " <> err) + expectationFailure ("Kesha.hash failed: " <> show err) + + optsToArgs :: Kesha.HashOptions -> [String] + optsToArgs (Kesha.HashOptions algo repr) = + ( case algo of + Kesha.MD5 -> ["--type", "md5"] + Kesha.SHA1 -> ["--type", "sha1"] + Kesha.SHA256 -> ["--type", "sha256"] + ) + <> ( case repr of + Kesha.Base16 -> [] + Kesha.Base32 -> ["--base32"] + ) data FSO = Regular FSO_Regular @@ -143,59 +172,55 @@ instance Arbitrary FSO where Directory <$> arbitrary ] -data FSO_Regular - = FSO_Regular - { _regularIsExecutable :: Bool, - regularName :: PathPiece, - _regularContents :: Contents - } +data FSO_Regular = FSO_Regular + { _regularIsExecutable :: Bool, + regularName :: PathSegment, + _regularContents :: Contents + } deriving (Show) instance Arbitrary FSO_Regular where arbitrary = FSO_Regular <$> arbitrary <*> arbitrary <*> arbitrary -data FSO_SymLink - = FSO_SymLink - { _symLinkIsFile :: Bool, - _symLinkTarget :: PathPiece, - symLinkName :: PathPiece - } +data FSO_SymLink = FSO_SymLink + { _symLinkIsFile :: Bool, + _symLinkTarget :: PathSegment, + symLinkName :: PathSegment + } deriving (Show) instance Arbitrary FSO_SymLink where arbitrary = FSO_SymLink <$> arbitrary <*> arbitrary <*> arbitrary -newtype FSO_Directory - = FSO_Directory {directoryMap :: Map.Map PathPiece FSO} - deriving newtype (Show) +newtype FSO_Directory = FSO_Directory {directoryMap :: Map.Map PathSegment FSO} + deriving (Show) instance Arbitrary FSO_Directory where arbitrary = - scale (min 5) $ sized $ \size -> do - len <- choose (0, size) - FSO_Directory . Map.fromList <$> vectorOf len (resize (pred size) arbitrary) + scale (min 5) $ + sized $ \size -> do + len <- choose (0, size) + FSO_Directory . Map.fromList <$> vectorOf len (resize (pred size) arbitrary) -newtype PathPiece - = PathPiece {unPathPiece :: String} -- FIXME: Text - deriving newtype (Eq, Ord, Show) +newtype PathSegment = PathSegment {unPathSegment :: String} + deriving (Eq, Ord, Show) -instance Arbitrary PathPiece where +instance Arbitrary PathSegment where arbitrary = do len <- choose (10, 20) - PathPiece <$> vectorOf len (elements validChars) + PathSegment <$> vectorOf len (elements validChars) where validChars :: String validChars = ['A' .. 'Z'] <> ['a' .. 'z'] -newtype Contents - = Contents {unContents :: BS.ByteString} - deriving newtype (Show) +newtype Contents = Contents {unContents :: BS.ByteString} + deriving (Show) instance Arbitrary Contents where arbitrary = fmap (Contents . BS.pack) arbitrary createFSO_Regular :: FSO_Regular -> IO FilePath -createFSO_Regular (FSO_Regular isExecutable (PathPiece path) contents) = do +createFSO_Regular (FSO_Regular isExecutable (PathSegment path) contents) = do BS.writeFile path (unContents contents) when isExecutable $ do perm <- Directory.getPermissions path @@ -203,7 +228,7 @@ createFSO_Regular (FSO_Regular isExecutable (PathPiece path) contents) = do pure path createFSO_SymLink :: FSO_SymLink -> IO FilePath -createFSO_SymLink (FSO_SymLink isFile (PathPiece target) (PathPiece name)) +createFSO_SymLink (FSO_SymLink isFile (PathSegment target) (PathSegment name)) | isFile = do BS.writeFile target mempty Directory.createFileLink target name @@ -225,9 +250,10 @@ createFSO_Directory root = case fso of Regular regular -> [(dir, Right regular {regularName = piece})] SymLink symLink -> [(dir, Left symLink {symLinkName = piece})] - Directory directory -> flattenNodes (dir unPathPiece piece) directory + Directory directory -> flattenNodes (dir unPathSegment piece) directory ) . directoryMap + writeNode :: FilePath -> Either FSO_SymLink FSO_Regular -> IO FilePath writeNode path (Left symLink) = do Directory.createDirectoryIfMissing True path @@ -236,8 +262,8 @@ createFSO_Directory root = Directory.createDirectoryIfMissing True path Directory.withCurrentDirectory path (createFSO_Regular regular) -nix_store_dump :: FilePath -> IO (Either Int BS.ByteString) -nix_store_dump path = do +nixStoreDump :: FilePath -> IO (Either Int BS.ByteString) +nixStoreDump path = do (_, Just hout, _, processHandle) <- Process.createProcess (Process.proc "nix-store" ["--dump", path]) @@ -248,11 +274,11 @@ nix_store_dump path = do Exit.ExitFailure code -> pure (Left code) Exit.ExitSuccess -> Right <$> BS.hGetContents hout -nix_hash :: FilePath -> IO (Either Int BS.ByteString) -nix_hash path = do +nixHash :: [String] -> FilePath -> IO (Either Int BS.ByteString) +nixHash args path = do (_, Just hout, _, processHandle) <- Process.createProcess - (Process.proc "nix-hash" ["--type", "sha256", "--base32", path]) + (Process.proc "nix-hash" (args ++ [path])) { Process.std_out = Process.CreatePipe } exit <- Process.waitForProcess processHandle