From 86faddcedf69c7bd4c5519806cdb26e7c5e6a318 Mon Sep 17 00:00:00 2001 From: Jordan Mackie Date: Mon, 8 Jun 2020 14:14:04 +0100 Subject: [PATCH] Simplify down to just a cabal package --- .hlint.yaml | 2 - .travis.yml | 2 +- LICENSE | 2 +- README.md | 23 +--- Setup.hs | 1 + app/Main.hs | 98 ---------------- ci.sh | 41 +++++++ default.nix | 52 --------- kesha.cabal | 35 +++--- shell.nix | 20 +++- src/Kesha.hs | 84 +++++++------- src/Kesha/NAR.hs | 165 ++++++++++++--------------- stack.yaml | 5 - test/Main.hs | 283 +++++++++++++++++++++++------------------------ 14 files changed, 326 insertions(+), 487 deletions(-) delete mode 100644 .hlint.yaml delete mode 100644 app/Main.hs create mode 100755 ci.sh delete mode 100644 default.nix delete mode 100644 stack.yaml diff --git a/.hlint.yaml b/.hlint.yaml deleted file mode 100644 index 46ac9bb..0000000 --- a/.hlint.yaml +++ /dev/null @@ -1,2 +0,0 @@ -- ignore: { name: "Redundant do" } -- ignore: { name: "Use camelCase" } diff --git a/.travis.yml b/.travis.yml index f90fef1..1c0ab9c 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,3 +1,3 @@ language: nix nix: 2.2.2 -script: nix build -f default.nix kesha +script: ci.sh diff --git a/LICENSE b/LICENSE index 903b91c..4b5ed0b 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2019 Jordan Mackie +Copyright (c) 2020 Jordan Mackie Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the diff --git a/README.md b/README.md index 9daaaf6..e860b7e 100644 --- a/README.md +++ b/README.md @@ -2,28 +2,7 @@ [![Build Status](https://travis-ci.org/jmackie/kesha.svg?branch=master)](https://travis-ci.org/jmackie/kesha) -A Haskell library and executable for computing the cryptographic hash of any path. +A Haskell library for computing the cryptographic hash of any path. The implementation is an almost verbatim port of `nix-hash`, which is the standard tool used by the [Nix](https://nixos.org/nix/) package manager. - -# Installation - -With [`cabal`](https://cabal.readthedocs.io/en/latest/) - -```bash -cabal new-install -``` - -with [`stack`](https://docs.haskellstack.org/en/latest/) - -```bash -stack install -``` - -with [Nix](https://nixos.org/nix/) - -```bash -nix build -f https://github.com/jmackie/kesha/archive/master.tar.gz kesha -o ./kesha -nix-env -i ./kesha -``` diff --git a/Setup.hs b/Setup.hs index 9a994af..e8ef27d 100644 --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/app/Main.hs b/app/Main.hs deleted file mode 100644 index 0051f21..0000000 --- a/app/Main.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -module Main (main) where - -import Prelude - -import qualified Data.ByteString as BS -import qualified System.Environment as Environment -import qualified Paths_kesha -import qualified Data.Version as Version - -import Data.Foldable (for_) -import System.IO (hPutStrLn, stderr) -import Data.List (intercalate) -import Data.Maybe (mapMaybe) - -import qualified Kesha - -main :: IO () -main = getCmd >>= runCmd - -usage :: String -usage = - "kesha: compute the cryptographic hash of filesystem paths \n\ - \ \n\ - \usage: kesha (--version | --help | paths...) \n\ - \ \n\ - \example: kesha ~/.bashrc ~/.cabal/logs/ \n\ - \" - -data Cmd - = VersionCmd - | HelpCmd - | BadUsageCmd BadUsageReason - | HashCmd [FilePath] - -data BadUsageReason - = UnknownFlags [String] - | MissingPaths - -runCmd :: Cmd -> IO () -runCmd VersionCmd = putStrLn (Version.showVersion Paths_kesha.version) -runCmd HelpCmd = putStrLn usage -runCmd (BadUsageCmd (UnknownFlags unknowns)) = do - putStrLn $ "unknown flags: " <> intercalate "," (fmap show unknowns) - putStrLn usage -runCmd (BadUsageCmd MissingPaths) = do - putStrLn "no paths specified\n" - putStrLn usage -runCmd (HashCmd paths) = - for_ paths $ \path -> do - result <- Kesha.hash path - case result of - Left err -> hPutStrLn stderr err - Right hash -> do - BS.putStr hash - putStr ("\t" <> path <> "\n") - -getCmd :: IO Cmd -getCmd = cmdFromArgs . fmap parseArg <$> Environment.getArgs - where - cmdFromArgs :: [Arg] -> Cmd - cmdFromArgs args - | unknowns@(_ : _) <- filterUnknownFlags args = BadUsageCmd (UnknownFlags unknowns) - | HelpFlag `elem` args = HelpCmd - | VersionFlag `elem` args = VersionCmd - | otherwise = - case filterPathArgs args of - [] -> BadUsageCmd MissingPaths - paths -> HashCmd paths - - filterUnknownFlags :: [Arg] -> [String] - filterUnknownFlags = - mapMaybe $ \case - UnknownFlag unknown -> Just unknown - _ -> Nothing - - filterPathArgs :: [Arg] -> [String] - filterPathArgs = - mapMaybe $ \case - PathArg path -> Just path - _ -> Nothing - -data Arg - = VersionFlag - | HelpFlag - | UnknownFlag String - | PathArg String - deriving (Eq) - -parseArg :: String -> Arg -parseArg arg = - case arg of - "--version" -> VersionFlag - "-v" -> VersionFlag - "--help" -> HelpFlag - "-h" -> HelpFlag - ('-' : _) -> UnknownFlag arg - _ -> PathArg arg diff --git a/ci.sh b/ci.sh new file mode 100755 index 0000000..e398bcd --- /dev/null +++ b/ci.sh @@ -0,0 +1,41 @@ +#!/usr/bin/env nix-shell +#! nix-shell -i bash + +set -euo pipefail +shopt -s inherit_errexit + +print_versions() { ( + set -x + ghc --version + cabal --version + hlint --version + ormolu --version +); } + +build_and_test() { + cabal new-update + cabal new-build + cabal new-test --test-show-details=streaming +} + +lint() { + hlint --git + + local exit=0 + for f in $(git ls-files | grep -e '\.hs'); do + if ! ormolu --mode check "$f"; then + echo 2>&1 "$f isn't formatted" + exit=1 + fi + done + + return $exit +} + +main() { + print_versions + build_and_test + lint +} + +main "$@" diff --git a/default.nix b/default.nix deleted file mode 100644 index 92873ec..0000000 --- a/default.nix +++ /dev/null @@ -1,52 +0,0 @@ -let - cabal-hashes-overlay = - # Update from Hackage at 2019-08-05T11:50:23Z - let rev = "ef12e2cf418a00852f174a68c33b907ee57e750f"; in - self: super: { - all-cabal-hashes = super.fetchurl { - url = "https://github.com/commercialhaskell/all-cabal-hashes/archive/${rev}.tar.gz"; - sha256 = "1rspbkmj0369y5hw81k3y9ns2v2bzsnqpi4dhnqd0qxxzv3n1am7"; - }; - }; - - pkgs = - # 2019-08-05 - let rev = "621880e5e761960d910b443ff9788c88baddc4f9"; in - import (builtins.fetchTarball { - name = "nixpkgs-${rev}"; - url = "https://github.com/nixos/nixpkgs/archive/${rev}.tar.gz"; - sha256 = "1jzhc0k07cy37sravy0s9mmwrddy0vnp3479d8ndk750ncb2sjx1"; - }) { overlays = [ cabal-hashes-overlay ]; }; - - haskellPackages = - pkgs.haskell.packages.ghc865.override { - overrides = self: super: { - }; - }; - - gitignore = - (import (pkgs.fetchFromGitHub { - owner = "hercules-ci"; - repo = "gitignore"; - rev = "ec5dd0536a5e4c3a99c797b86180f7261197c124"; - sha256 = "0k2r8y21rn4kr5dmddd3906x0733fs3bb8hzfpabkdav3wcy3klv"; - }) { inherit (pkgs) lib; }).gitignoreSource; - - kesha = - (haskellPackages.callCabal2nix "kesha" (gitignore ./.) {}).overrideAttrs - # Need `nix-*` tools for testing - (attrs: { buildInputs = attrs.buildInputs ++ [ pkgs.nix ]; }); -in -{ - inherit kesha; - env = haskellPackages.shellFor { - packages = p: [ - kesha - ]; - - buildInputs = [ - # Hardcode some global arguments to `stack` to make life easier - (pkgs.writeShellScriptBin "stack" "${pkgs.stack}/bin/stack --no-nix --system-ghc $@") - ]; - }; -} diff --git a/kesha.cabal b/kesha.cabal index 892c8d2..f92554f 100644 --- a/kesha.cabal +++ b/kesha.cabal @@ -13,7 +13,7 @@ license: MIT license-file: LICENSE author: Jordan Mackie maintainer: jmackie@protonmail.com -copyright: (c) 2019 Jordan Mackie +copyright: (c) 2020 Jordan Mackie category: System extra-source-files: README.md @@ -28,52 +28,43 @@ source-repository head library default-language: Haskell2010 hs-source-dirs: src - ghc-options: -Wall + ghc-options: -Wall exposed-modules: Kesha Kesha.NAR build-depends: -- https://wiki.haskell.org/Base_package + -- >= 8.2.2 && < 8.9 base >= 4.10.1 && < 4.14, + -- boot libraries binary, bytestring, containers, - cryptohash-sha256, + -- 1.3.1.0 introduced `getSymbolicLinkTarget` directory >= 1.3.1, filepath, - text + text, -executable kesha - default-language: Haskell2010 - hs-source-dirs: app - ghc-options: -Wall -threaded -O2 -rtsopts -with-rtsopts=-N - main-is: Main.hs - other-modules: Paths_kesha - build-depends: - base >= 4.10.1 && < 4.14, - - bytestring, - - kesha + cryptohash-sha256 test-suite test + default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: test ghc-options: -Wall -threaded -rtsopts build-depends: + kesha, + base >= 4.10.1 && < 4.14, - QuickCheck, bytestring, containers, directory >= 1.3.1, filepath, - hspec, process, - temporary, - kesha - other-modules: - default-language: Haskell2010 + hspec, + QuickCheck, + temporary diff --git a/shell.nix b/shell.nix index fb83e92..bce3a75 100644 --- a/shell.nix +++ b/shell.nix @@ -1 +1,19 @@ -(import ./.).env +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 + ]; +} + diff --git a/src/Kesha.hs b/src/Kesha.hs index 752200c..8a27bf9 100644 --- a/src/Kesha.hs +++ b/src/Kesha.hs @@ -1,51 +1,48 @@ {-# LANGUAGE OverloadedStrings #-} -module Kesha - ( hash - , hashWith - - , Opts(..) - , defaultOpts - , HashAlgo(..) - , HashRepr(..) - ) where -import Prelude hiding ((!!)) +module Kesha + ( hash, + hashWith, + Opts (..), + defaultOpts, + HashAlgo (..), + HashRepr (..), + ) +where import qualified Crypto.Hash.SHA256 as SHA256 +import Data.Bits ((.&.), (.|.), shiftL, shiftR) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as ASCII import qualified Data.Char as Char -import qualified Data.Sequence as Seq - -import Data.Bits ((.&.), (.|.), shiftL, shiftR) import Data.Maybe (fromJust) +import qualified Data.Sequence as Seq import Data.Word (Word8) - import qualified Kesha.NAR as NAR +import Prelude hiding ((!!)) --- | +-- | -- Compute the cryptographic hash of a path using the 'defaultOpts'. -- --- The output of @'hash' path@ should be consistent with that of +-- 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 --- | +-- | -- Compute the cryptographic hash of a path using the given 'Opts'. --- hashWith :: Opts -> FilePath -> IO (Either String BS.ByteString) hashWith opts path = fmap (printNar (hashAlgo opts) (hashRepr opts)) <$> NAR.localPack path --- | +-- | -- Hashing options. --- data Opts = Opts - { hashAlgo :: HashAlgo -- ^ cryptographic hash algorithm to use - , hashRepr :: HashRepr -- ^ how to print the hash + { -- | cryptographic hash algorithm to use + hashAlgo :: HashAlgo, + -- | how to print the hash + hashRepr :: HashRepr } -- | @@ -53,28 +50,25 @@ data Opts -- -- These are the default options used by most of the Nix tooling (e.g. -- @nix-prefetch-git@). --- defaultOpts :: Opts defaultOpts = Opts SHA256 Base32 -- | -- Available hash algorithms. --- data HashAlgo = SHA256 --- | +-- | -- Printable hash representations. --- data HashRepr = Base32 printNar :: HashAlgo -> HashRepr -> NAR.NAR -> BS.ByteString -printNar SHA256 Base32 - = ASCII.map Char.toLower - . printHash32 SHA256 - . SHA256.hash - . NAR.dump +printNar SHA256 Base32 = + ASCII.map Char.toLower + . printHash32 SHA256 + . SHA256.hash + . NAR.dump -- https://github.com/NixOS/nix/blob/master/src/libutil/hash.cc printHash32 :: HashAlgo -> BS.ByteString -> BS.ByteString @@ -82,29 +76,25 @@ printHash32 algo rawHash = go (len - 1) "" where hashSize :: Int hashSize = hashSizeForAlgo algo - len :: Int len = (hashSize * 8 - 1) `div` 5 + 1 - go :: Int -> BS.ByteString -> BS.ByteString go n accum | n < 0 = accum | otherwise = - go (pred n) $ - ASCII.snoc accum (base32Chars !! (fromIntegral c .&. 0x1f)) - where - b, i, j :: Int - b = n * 5 - i = b `div` 8 - j = b `mod` 8 - - c :: Word8 - c = ((bytes !! i) `shiftR` j) .|. - (if i >= (hashSize - 1) then 0 else (bytes !! (i + 1)) `shiftL` (8 - j)) - + go (pred n) $ + ASCII.snoc accum (base32Chars !! (fromIntegral c .&. 0x1f)) + where + b , i, j :: Int + b = n * 5 + i = b `div` 8 + j = b `mod` 8 + c :: Word8 + 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 !! diff --git a/src/Kesha/NAR.hs b/src/Kesha/NAR.hs index 856fd48..bf6ff3e 100644 --- a/src/Kesha/NAR.hs +++ b/src/Kesha/NAR.hs @@ -1,38 +1,36 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + -- | -- Implementation of the Nix ARchive format (NAR) -- -- https://nixos.org/~eelco/pubs/phd-thesis.pdf --- module Kesha.NAR - ( NAR - , localPack - , dump - ) where - -import Prelude + ( NAR, + localPack, + dump, + ) +where +import Control.Monad (when) +import Data.Bifunctor (second) import qualified Data.Binary.Put as Binary import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL +import Data.Foldable (for_, traverse_) import qualified Data.List as List import qualified Data.Map as Map -import qualified Data.Text as Text -import qualified System.Directory as Directory - -import Control.Monad (when) -import Data.Bifunctor (second) -import Data.Foldable (traverse_, for_) import Data.Semigroup ((<>)) +import qualified Data.Text as Text import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) import Data.Traversable (for) +import qualified System.Directory as Directory import System.FilePath (()) +import Prelude -- | --- A packed NAR archive. --- +-- A packed NAR archive. newtype NAR = NAR FSO data FSO @@ -45,7 +43,8 @@ type IsExecutable = Bool type Size = Int type Utf8FilePath = Text -type PathPiece = Text -- shouldn't include '/' or 'NUL' ! + +type PathPiece = Text -- shouldn't include '/' or 'NUL' ! data PathType = RegularType @@ -53,11 +52,10 @@ data PathType | DirectoryType | AmbiguousType --- | +-- | -- 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 path = second NAR <$> localPackFSO path @@ -66,108 +64,91 @@ localPackFSO path = guessPathType path >>= \case Nothing -> pure $ Left (path <> ": path doesn't exist") - Just AmbiguousType -> pure $ Left (path <> ": couldn't work out file type") - Just RegularType -> do isExecutable <- Directory.executable <$> Directory.getPermissions path size <- fromIntegral <$> Directory.getFileSize path contents <- BS.readFile path let fso = Regular isExecutable size contents pure $ Right fso - Just SymLinkType -> do target <- Directory.getSymbolicLinkTarget path let fso = SymLink (Text.pack target) pure $ Right fso - Just DirectoryType -> do fs <- Directory.listDirectory path entries <- for fs $ \path' -> do results <- localPackFSO (path path') pure (Text.pack path', results) - pure $ - second (Directory . Map.fromList) - (traverse sequence entries) + second + (Directory . Map.fromList) + (traverse sequence entries) -- | -- Serialize a NAR archive. --- dump :: NAR -> BS.ByteString dump = BSL.toStrict . Binary.runPut . putNAR putNAR :: NAR -> Binary.Put putNAR (NAR fso) = str "nix-archive-1" <> parens (putFSO fso) where - putFSO :: FSO -> Binary.Put - putFSO = \case - Regular isExecutable size contents -> do - strs ["type", "regular"] - when isExecutable $ strs ["executable", ""] - str "contents" - int size - pad size contents - - SymLink target -> do - strs ["type", "symlink"] - strs ["target", encodeUtf8 target] - - Directory entries -> do - strs ["type", "directory"] - let sortedEntries = List.sortOn fst (Map.toList entries) - - for_ sortedEntries $ \(name, node) -> do - str "entry" - parens $ do - str "name" - 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 + putFSO :: FSO -> Binary.Put + putFSO = \case + Regular isExecutable size contents -> do + strs ["type", "regular"] + when isExecutable $ strs ["executable", ""] + str "contents" + int size + pad size contents + SymLink target -> do + strs ["type", "symlink"] + strs ["target", encodeUtf8 target] + Directory entries -> do + strs ["type", "directory"] + let sortedEntries = List.sortOn fst (Map.toList entries) + for_ sortedEntries $ \(name, node) -> do + str "entry" + parens $ do + str "name" + 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 guessPathType :: FilePath -> IO (Maybe PathType) guessPathType path = do pathExists <- Directory.doesPathExist path if not pathExists - then pure Nothing - else do - clues <- (,,) - -- returns True if the argument file exists and is not a directory, - <$> Directory.doesFileExist path - - -- returns True if the argument file exists and is either a directory or - -- a symbolic link to a directory - <*> Directory.doesDirectoryExist path - - -- Check whether the path refers to a symbolic link - <*> Directory.pathIsSymbolicLink path - - case clues of - (True, False, True) -> pure (Just SymLinkType) - (True, False, False) -> pure (Just RegularType) - (False, True, True) -> pure (Just SymLinkType) - (False, True, False) -> pure (Just DirectoryType) - - _ -> pure (Just AmbiguousType) + then pure Nothing + else do + clues <- + (,,) + -- returns True if the argument file exists and is not a directory, + <$> Directory.doesFileExist path + -- returns True if the argument file exists and is either a directory or + -- a symbolic link to a directory + <*> Directory.doesDirectoryExist path + -- Check whether the path refers to a symbolic link + <*> Directory.pathIsSymbolicLink path + case clues of + (True, False, True) -> pure (Just SymLinkType) + (True, False, False) -> pure (Just RegularType) + (False, True, True) -> pure (Just SymLinkType) + (False, True, False) -> pure (Just DirectoryType) + _ -> pure (Just AmbiguousType) diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 index 319c7de..0000000 --- a/stack.yaml +++ /dev/null @@ -1,5 +0,0 @@ -resolver: lts-13.30 # ghc-8.6.5 -packages: - - . -# NOTE: -# curl https://www.stackage.org/lts-13.30/cabal.config > cabal.project.freeze diff --git a/test/Main.hs b/test/Main.hs index 9e8249d..3f4b252 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,67 +1,70 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} -module Main (main) where +{-# LANGUAGE OverloadedStrings #-} -import Prelude +module Main + ( main, + ) +where -import qualified Data.ByteString as BS -import qualified Data.Map as Map -import qualified System.Directory as Directory -import qualified System.Exit as Exit -import qualified System.IO.Temp as Temp -import qualified System.Process as Process +{- HLINT ignore "Redundant do" -} +{- HLINT ignore "Use camelCase" -} import Control.Applicative (liftA2) import Control.Monad (when) +import qualified Data.ByteString as BS import Data.Foldable (traverse_) -import System.FilePath (()) +import qualified Data.Map as Map import Data.Semigroup ((<>)) - import qualified Kesha import qualified Kesha.NAR - +import qualified System.Directory as Directory +import qualified System.Exit as Exit +import System.FilePath (()) +import qualified System.IO.Temp as Temp +import qualified System.Process as Process import Test.Hspec - ( Spec - , Expectation - , describe - , expectationFailure - , hspec - , it - , shouldBe - ) -import Test.QuickCheck - ( Arbitrary(..) - , choose - , elements - , oneof - , property - , resize - , scale - , sized - , vectorOf + ( Expectation, + Spec, + describe, + expectationFailure, + hspec, + it, + shouldBe, ) import Test.Hspec.QuickCheck - ( modifyMaxSuccess + ( modifyMaxSuccess, ) +import Test.QuickCheck + ( Arbitrary (..), + choose, + elements, + oneof, + property, + resize, + scale, + sized, + vectorOf, + ) +import Prelude main :: IO () main = do - exes <- liftA2 (,) (Directory.findExecutable "nix-store") - (Directory.findExecutable "nix-hash") + exes <- + liftA2 + (,) + (Directory.findExecutable "nix-store") + (Directory.findExecutable "nix-hash") case exes of (Nothing, Nothing) -> do putStrLn "Nix tooling not found on path - skipping tests" - (Just _, Nothing) -> do putStrLn "`nix-store` not found on path - aborting" Exit.exitFailure - - (Nothing , Just _) -> do + (Nothing, Just _) -> do putStrLn "`nix-hash` not found on path - aborting" Exit.exitFailure - (Just _, Just _) -> Temp.withSystemTempDirectory "kesha-test" (hspec . spec) @@ -69,69 +72,62 @@ 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 -> + 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 sha256 --base32`" $ do + modifyMaxSuccess (const 20) + $ it "matches for any FSO" + $ property + $ \case + Regular regular -> inTempDirectory tempDir "Regular" $ - checkNAR =<< createFSO_Regular regular - - modifyMaxSuccess (const 20) $ - it "matches for SymLinks" $ - property $ \symLink -> do + checkHash =<< createFSO_Regular regular + SymLink symLink -> inTempDirectory tempDir "SymLink" $ - checkNAR =<< createFSO_SymLink symLink - - modifyMaxSuccess (const 20) $ - it "matches for Directories" $ - property $ \directory -> + checkHash =<< createFSO_SymLink symLink + Directory directory -> Temp.withTempDirectory tempDir "Directory" $ \path -> do createFSO_Directory path directory - checkNAR path - - describe "Hashing" $ do - 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 + checkHash path where - checkNAR :: FilePath -> Expectation - checkNAR path = do - result <- liftA2 (,) (nix_store_dump 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) - 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) + checkNAR :: FilePath -> Expectation + checkNAR path = do + result <- liftA2 (,) (nix_store_dump 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) + 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) data FSO = Regular FSO_Regular @@ -140,18 +136,19 @@ data FSO deriving (Show) instance Arbitrary FSO where - arbitrary = oneof - [ Regular <$> arbitrary - , SymLink <$> arbitrary - , Directory <$> arbitrary - ] + arbitrary = + oneof + [ Regular <$> arbitrary, + SymLink <$> arbitrary, + Directory <$> arbitrary + ] data FSO_Regular = FSO_Regular - { _regularIsExecutable :: Bool - , regularName :: PathPiece - , _regularContents :: Contents - } + { _regularIsExecutable :: Bool, + regularName :: PathPiece, + _regularContents :: Contents + } deriving (Show) instance Arbitrary FSO_Regular where @@ -159,9 +156,9 @@ instance Arbitrary FSO_Regular where data FSO_SymLink = FSO_SymLink - { _symLinkIsFile :: Bool - , _symLinkTarget :: PathPiece - , symLinkName :: PathPiece + { _symLinkIsFile :: Bool, + _symLinkTarget :: PathPiece, + symLinkName :: PathPiece } deriving (Show) @@ -169,7 +166,7 @@ instance Arbitrary FSO_SymLink where arbitrary = FSO_SymLink <$> arbitrary <*> arbitrary <*> arbitrary newtype FSO_Directory - = FSO_Directory { directoryMap :: Map.Map PathPiece FSO } + = FSO_Directory {directoryMap :: Map.Map PathPiece FSO} deriving newtype (Show) instance Arbitrary FSO_Directory where @@ -179,7 +176,7 @@ instance Arbitrary FSO_Directory where FSO_Directory . Map.fromList <$> vectorOf len (resize (pred size) arbitrary) newtype PathPiece - = PathPiece { unPathPiece :: String } -- FIXME: Text + = PathPiece {unPathPiece :: String} -- FIXME: Text deriving newtype (Eq, Ord, Show) instance Arbitrary PathPiece where @@ -187,11 +184,11 @@ instance Arbitrary PathPiece where len <- choose (10, 20) PathPiece <$> vectorOf len (elements validChars) where - validChars :: String - validChars = ['A'..'Z'] <> ['a'..'z'] + validChars :: String + validChars = ['A' .. 'Z'] <> ['a' .. 'z'] newtype Contents - = Contents { unContents :: BS.ByteString } + = Contents {unContents :: BS.ByteString} deriving newtype (Show) instance Arbitrary Contents where @@ -202,51 +199,50 @@ createFSO_Regular (FSO_Regular isExecutable (PathPiece path) contents) = do BS.writeFile path (unContents contents) when isExecutable $ do perm <- Directory.getPermissions path - Directory.setPermissions path perm { Directory.executable = True } + Directory.setPermissions path perm {Directory.executable = True} pure path createFSO_SymLink :: FSO_SymLink -> IO FilePath createFSO_SymLink (FSO_SymLink isFile (PathPiece target) (PathPiece name)) | isFile = do - BS.writeFile target mempty - Directory.createFileLink target name - pure target + BS.writeFile target mempty + Directory.createFileLink target name + pure target | otherwise = do - Directory.createDirectory target - Directory.createDirectoryLink target name - pure target + Directory.createDirectory target + Directory.createDirectoryLink target name + pure target createFSO_Directory :: FilePath -> FSO_Directory -> IO () createFSO_Directory root = traverse_ (uncurry writeNode) . flattenNodes root where - flattenNodes - :: FilePath -> FSO_Directory -> [(FilePath, Either FSO_SymLink FSO_Regular)] - flattenNodes dir = - Map.foldMapWithKey - (\piece fso -> - case fso of - Regular regular -> [(dir, Right regular { regularName = piece } )] - SymLink symLink -> [(dir, Left symLink { symLinkName = piece } )] - Directory directory -> flattenNodes (dir unPathPiece piece) directory) - . directoryMap - - writeNode :: FilePath -> Either FSO_SymLink FSO_Regular -> IO FilePath - writeNode path (Left symLink) = do - Directory.createDirectoryIfMissing True path - Directory.withCurrentDirectory path (createFSO_SymLink symLink) - - writeNode path (Right regular) = do - Directory.createDirectoryIfMissing True path - Directory.withCurrentDirectory path (createFSO_Regular regular) + flattenNodes :: + FilePath -> FSO_Directory -> [(FilePath, Either FSO_SymLink FSO_Regular)] + flattenNodes dir = + Map.foldMapWithKey + ( \piece fso -> + case fso of + Regular regular -> [(dir, Right regular {regularName = piece})] + SymLink symLink -> [(dir, Left symLink {symLinkName = piece})] + Directory directory -> flattenNodes (dir unPathPiece piece) directory + ) + . directoryMap + writeNode :: FilePath -> Either FSO_SymLink FSO_Regular -> IO FilePath + writeNode path (Left symLink) = do + Directory.createDirectoryIfMissing True path + Directory.withCurrentDirectory path (createFSO_SymLink symLink) + writeNode path (Right regular) = do + Directory.createDirectoryIfMissing True path + Directory.withCurrentDirectory path (createFSO_Regular regular) nix_store_dump :: FilePath -> IO (Either Int BS.ByteString) nix_store_dump path = do (_, Just hout, _, processHandle) <- Process.createProcess (Process.proc "nix-store" ["--dump", path]) - { Process.std_out = Process.CreatePipe } - + { Process.std_out = Process.CreatePipe + } exit <- Process.waitForProcess processHandle case exit of Exit.ExitFailure code -> pure (Left code) @@ -257,15 +253,14 @@ nix_hash path = do (_, Just hout, _, processHandle) <- Process.createProcess (Process.proc "nix-hash" ["--type", "sha256", "--base32", path]) - { Process.std_out = Process.CreatePipe } - + { Process.std_out = Process.CreatePipe + } exit <- Process.waitForProcess processHandle case exit of Exit.ExitFailure code -> pure (Left code) Exit.ExitSuccess -> + -- `BS.init` is to drop the trailing newline Right . BS.init <$> BS.hGetContents hout - -- ^^^^^^ - -- Need to drop the trailing newline inTempDirectory :: FilePath -> String -> IO a -> IO a inTempDirectory parent template m =