diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,13 @@ # Revision history for hnix-store-remote -## [0.5.0.0](https://github.com/haskell-nix/hnix-store/compare/0.4.3.0...0.5.0.0) 2021-06-11 +## [0.6.0.0](https://github.com/haskell-nix/hnix-store/compare/remote-0.5.0.0...remote-0.6.0.0) 2021-06-06 + +* Breaking: + * [(link)](https://github.com/haskell-nix/hnix-store/pull/179) `System.Nix.Store.Remote`: + * `addToStore` no longer accepts `FilePath` as its second argument but uses + more generic `NarSource` [(NarSource PR)](https://github.com/haskell-nix/hnix-store/pull/177) + +## [0.5.0.0](https://github.com/haskell-nix/hnix-store/compare/0.4.3.0...remote-0.5.0.0) 2021-06-11 * Breaking: * [(link)](https://github.com/haskell-nix/hnix-store/commit/3b948d112aa9307b0451258f28c7ee5dc86b24c7) `System.Nix.Store.Remote`: diff --git a/hnix-store-remote.cabal b/hnix-store-remote.cabal --- a/hnix-store-remote.cabal +++ b/hnix-store-remote.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hnix-store-remote -version: 0.5.0.0 +version: 0.6.0.0 synopsis: Remote hnix store description: Implementation of the nix store using the daemon protocol. homepage: https://github.com/haskell-nix/hnix-store @@ -39,7 +39,8 @@ , System.Nix.Store.Remote.Util build-depends: - base >=4.10 && <5 + base >=4.12 && <5 + , relude >= 1.0 , attoparsec , binary , bytestring @@ -51,7 +52,30 @@ , nix-derivation >= 1.1.1 && <2 , mtl , unordered-containers - , hnix-store-core >= 0.5 && <0.6 + , hnix-store-core >= 0.6 && <0.7 + mixins: + base hiding (Prelude) + , relude (Relude as Prelude) + , relude + default-extensions: + OverloadedStrings + , DeriveGeneric + , DeriveDataTypeable + , DeriveFunctor + , DeriveFoldable + , DeriveTraversable + , DeriveLift + , FlexibleContexts + , FlexibleInstances + , StandaloneDeriving + , TypeApplications + , TypeSynonymInstances + , InstanceSigs + , MultiParamTypeClasses + , TupleSections + , LambdaCase + , BangPatterns + , ViewPatterns hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -66,8 +90,7 @@ type: exitcode-stdio-1.0 main-is: Driver.hs other-modules: - Derivation - , NixDaemon + NixDaemon , Spec , Util hs-source-dirs: tests @@ -75,6 +98,7 @@ tasty-discover:tasty-discover build-depends: base + , relude , hnix-store-core >= 0.3 , hnix-store-remote , containers @@ -89,10 +113,30 @@ , tasty-hspec , tasty-quickcheck , linux-namespaces - , nix-derivation , temporary - , text , unix , unordered-containers - , vector + mixins: + base hiding (Prelude) + , relude (Relude as Prelude) + , relude + default-extensions: + OverloadedStrings + , DeriveGeneric + , DeriveDataTypeable + , DeriveFunctor + , DeriveFoldable + , DeriveTraversable + , DeriveLift + , FlexibleContexts + , FlexibleInstances + , StandaloneDeriving + , TypeApplications + , TypeSynonymInstances + , InstanceSigs + , MultiParamTypeClasses + , TupleSections + , LambdaCase + , BangPatterns + , ViewPatterns default-language: Haskell2010 diff --git a/src/System/Nix/Store/Remote.hs b/src/System/Nix/Store/Remote.hs --- a/src/System/Nix/Store/Remote.hs +++ b/src/System/Nix/Store/Remote.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE RecordWildCards #-} +{-# language AllowAmbiguousTypes #-} +{-# language KindSignatures #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language DataKinds #-} +{-# language RecordWildCards #-} +{-# language LiberalTypeSynonyms #-} + module System.Nix.Store.Remote ( addToStore , addTextToStore @@ -35,19 +35,14 @@ ) where -import Control.Monad ( void - , unless - , when - ) -import Data.ByteString.Lazy ( ByteString ) -import Data.Map.Strict ( Map ) -import Data.Text ( Text ) +import Prelude hiding ( putText ) +import qualified Data.ByteString.Lazy as BSL import Nix.Derivation ( Derivation ) import System.Nix.Build ( BuildMode , BuildResult ) -import System.Nix.Hash ( NamedAlgo +import System.Nix.Hash ( NamedAlgo(..) , SomeNamedDigest(..) , BaseEncoding(NixBase32) , decodeDigestWith @@ -63,13 +58,9 @@ import System.Nix.Internal.Base ( encodeWith ) import qualified Data.Binary.Put -import qualified Data.ByteString.Lazy import qualified Data.Map.Strict import qualified Data.Set -import qualified Data.Text.Encoding -import qualified System.Nix.Nar -import qualified System.Nix.Hash import qualified System.Nix.StorePath import qualified System.Nix.Store.Remote.Parsers @@ -78,36 +69,29 @@ import System.Nix.Store.Remote.Protocol import System.Nix.Store.Remote.Util import Crypto.Hash ( SHA256 ) -import Data.Coerce ( coerce ) +import System.Nix.Nar ( NarSource ) type RepairFlag = Bool type CheckFlag = Bool type SubstituteFlag = Bool --- | Pack `FilePath` as `Nar` and add it to the store. +-- | Pack `Nar` and add it to the store. addToStore :: forall a - . NamedAlgo a + . (NamedAlgo a) => StorePathName -- ^ Name part of the newly created `StorePath` - -> FilePath -- ^ Local `FilePath` to add + -> NarSource MonadStore -- ^ provide nar stream -> Bool -- ^ Add target directory recursively - -> (FilePath -> Bool) -- ^ Path filter function -> RepairFlag -- ^ Only used by local store backend -> MonadStore StorePath -addToStore name pth recursive _pathFilter _repair = do - +addToStore name source recursive _repair = do runOpArgsIO AddToStore $ \yield -> do - yield $ Data.ByteString.Lazy.toStrict $ Data.Binary.Put.runPut $ do + yield $ toStrict $ Data.Binary.Put.runPut $ do putText $ System.Nix.StorePath.unStorePathName name - putBool $ not $ System.Nix.Hash.algoName @a == "sha256" && recursive - putBool recursive - putText $ System.Nix.Hash.algoName @a - - System.Nix.Nar.streamNarIO yield System.Nix.Nar.narEffectsIO pth - + source yield sockGetPath -- | Add text to store. @@ -129,7 +113,7 @@ putPaths references' sockGetPath -addSignatures :: StorePath -> [ByteString] -> MonadStore () +addSignatures :: StorePath -> [BSL.ByteString] -> MonadStore () addSignatures p signatures = do void $ simpleOpArgs AddSignatures $ do putPath p @@ -171,15 +155,14 @@ -- Intentionally the only warning that should pop-up. putInt (0 :: Integer) - res <- getSocketIncremental getBuildResult - pure res + getSocketIncremental getBuildResult ensurePath :: StorePath -> MonadStore () ensurePath pn = do void $ simpleOpArgs EnsurePath $ putPath pn -- | Find garbage collector roots. -findRoots :: MonadStore (Map ByteString StorePath) +findRoots :: MonadStore (Map BSL.ByteString StorePath) findRoots = do runOp FindRoots sd <- getStoreDir @@ -187,7 +170,7 @@ getSocketIncremental $ getMany $ (,) - <$> (Data.ByteString.Lazy.fromStrict <$> getByteStringLen) + <$> (fromStrict <$> getByteStringLen) <*> getPath sd r <- catRights res @@ -198,7 +181,7 @@ ex :: (a, Either [Char] b) -> MonadStore (a, b) ex (x , Right y) = pure (x, y) - ex (_x, Left e ) = error $ "Unable to decode root: " <> e + ex (_x, Left e ) = error $ "Unable to decode root: " <> fromString e isValidPathUncached :: StorePath -> MonadStore Bool isValidPathUncached p = do @@ -235,13 +218,13 @@ deriverPath <- sockGetPathMay - narHashText <- Data.Text.Encoding.decodeUtf8 <$> sockGetStr + narHashText <- decodeUtf8 <$> sockGetStr let narHash = case decodeDigestWith @SHA256 NixBase32 narHashText of - Left e -> error e + Left e -> error $ fromString e Right x -> SomeDigest x references <- sockGetPaths @@ -260,7 +243,7 @@ case System.Nix.Store.Remote.Parsers.parseContentAddressableAddress caString of - Left e -> error e + Left e -> error $ fromString e Right x -> Just x trust = if ultimate then BuiltLocally else BuiltElsewhere @@ -291,9 +274,7 @@ queryPathFromHashPart storePathHash = do runOpArgs QueryPathFromHashPart $ putByteStringLen - $ Data.ByteString.Lazy.fromStrict - $ Data.Text.Encoding.encodeUtf8 - $ encodeWith NixBase32 $ coerce storePathHash + $ encodeUtf8 (encodeWith NixBase32 $ coerce storePathHash) sockGetPath queryMissing diff --git a/src/System/Nix/Store/Remote/Binary.hs b/src/System/Nix/Store/Remote/Binary.hs --- a/src/System/Nix/Store/Remote/Binary.hs +++ b/src/System/Nix/Store/Remote/Binary.hs @@ -4,10 +4,8 @@ |-} module System.Nix.Store.Remote.Binary where -import Control.Monad import Data.Binary.Get import Data.Binary.Put -import Data.ByteString ( ByteString ) import qualified Data.ByteString.Lazy as BSL putInt :: Integral a => a -> Put @@ -35,7 +33,7 @@ where len :: Int len = fromIntegral $ BSL.length x - pad count = sequence_ $ replicate count (putWord8 0) + pad count = replicateM_ count (putWord8 0) putByteStrings :: Foldable t => t BSL.ByteString -> Put putByteStrings = putMany putByteStringLen @@ -47,8 +45,8 @@ when (len `mod` 8 /= 0) $ do pads <- unpad $ fromIntegral $ 8 - (len `mod` 8) unless (all (== 0) pads) $ fail $ "No zeroes" <> show (st, len, pads) - pure $ BSL.toStrict st - where unpad x = sequence $ replicate x getWord8 + pure $ toStrict st + where unpad x = replicateM x getWord8 getByteStrings :: Get [ByteString] getByteStrings = getMany getByteStringLen diff --git a/src/System/Nix/Store/Remote/Builders.hs b/src/System/Nix/Store/Remote/Builders.hs --- a/src/System/Nix/Store/Remote/Builders.hs +++ b/src/System/Nix/Store/Remote/Builders.hs @@ -1,38 +1,36 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} +{-# language AllowAmbiguousTypes #-} +{-# language ScopedTypeVariables #-} +{-# language RankNTypes #-} module System.Nix.Store.Remote.Builders ( buildContentAddressableAddress ) where -import Data.Text.Lazy ( Text ) +import qualified Data.Text.Lazy as TL import Crypto.Hash ( Digest ) import System.Nix.StorePath ( ContentAddressableAddress(..) ) import Data.Text.Lazy.Builder ( Builder ) -import qualified Data.Text.Lazy.Builder +import qualified Data.Text.Lazy.Builder as TL import System.Nix.Hash -- | Marshall `ContentAddressableAddress` to `Text` -- in form suitable for remote protocol usage. -buildContentAddressableAddress :: ContentAddressableAddress -> Text +buildContentAddressableAddress :: ContentAddressableAddress -> TL.Text buildContentAddressableAddress = - Data.Text.Lazy.Builder.toLazyText . contentAddressableAddressBuilder + TL.toLazyText . contentAddressableAddressBuilder contentAddressableAddressBuilder :: ContentAddressableAddress -> Builder contentAddressableAddressBuilder (Text digest) = "text:" <> digestBuilder digest contentAddressableAddressBuilder (Fixed _narHashMode (SomeDigest (digest :: Digest hashAlgo))) = "fixed:" - <> (Data.Text.Lazy.Builder.fromText $ System.Nix.Hash.algoName @hashAlgo) + <> TL.fromText (System.Nix.Hash.algoName @hashAlgo) <> digestBuilder digest digestBuilder :: Digest a -> Builder digestBuilder = - Data.Text.Lazy.Builder.fromText . encodeDigestWith NixBase32 + TL.fromText . encodeDigestWith NixBase32 diff --git a/src/System/Nix/Store/Remote/Logger.hs b/src/System/Nix/Store/Remote/Logger.hs --- a/src/System/Nix/Store/Remote/Logger.hs +++ b/src/System/Nix/Store/Remote/Logger.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RankNTypes #-} +{-# language RankNTypes #-} module System.Nix.Store.Remote.Logger ( Logger(..) @@ -8,9 +8,8 @@ where -import Control.Monad.Except -import Control.Monad.Reader ( asks ) -import Control.Monad.State ( get ) +import Prelude hiding ( Last ) +import Control.Monad.Except ( throwError ) import Data.Binary.Get import Network.Socket.ByteString ( recv ) @@ -60,8 +59,7 @@ sockPut $ putByteStringLen part clearData - next <- go decoder - pure next + go decoder -- we should probably handle Read here as well x -> do @@ -72,12 +70,12 @@ chunk <- liftIO (Just <$> recv soc 8) go (k chunk) - go (Fail _leftover _consumed msg) = error msg + go (Fail _leftover _consumed msg) = error $ fromString msg getFields :: Get [Field] getFields = do cnt <- getInt - sequence $ replicate cnt getField + replicateM cnt getField getField :: Get Field getField = do diff --git a/src/System/Nix/Store/Remote/Parsers.hs b/src/System/Nix/Store/Remote/Parsers.hs --- a/src/System/Nix/Store/Remote/Parsers.hs +++ b/src/System/Nix/Store/Remote/Parsers.hs @@ -1,20 +1,14 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeApplications #-} +{-# language AllowAmbiguousTypes #-} +{-# language ScopedTypeVariables #-} +{-# language RankNTypes #-} +{-# language DataKinds #-} module System.Nix.Store.Remote.Parsers ( parseContentAddressableAddress ) where -import Control.Applicative ( (<|>) ) import Data.Attoparsec.ByteString.Char8 -import Data.ByteString.Char8 -import Data.Text ( Text ) -import Data.Text.Encoding ( decodeUtf8 ) import System.Nix.Hash import System.Nix.StorePath ( ContentAddressableAddress(..) , NarHashMode(..) @@ -42,7 +36,7 @@ caFixed :: Parser ContentAddressableAddress caFixed = do _ <- "fixed:" - narHashMode <- (pure Recursive <$> "r:") <|> (pure RegularFile <$> "") + narHashMode <- (Recursive <$ "r:") <|> (RegularFile <$ "") digest <- parseTypedDigest either fail pure $ Fixed narHashMode <$> digest diff --git a/src/System/Nix/Store/Remote/Protocol.hs b/src/System/Nix/Store/Remote/Protocol.hs --- a/src/System/Nix/Store/Remote/Protocol.hs +++ b/src/System/Nix/Store/Remote/Protocol.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# language DataKinds #-} +{-# language ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} module System.Nix.Store.Remote.Protocol ( WorkerOp(..) , simpleOp @@ -10,24 +10,23 @@ , runOpArgsIO , runStore , runStoreOpts + , runStoreOptsTCP + , runStoreOpts' ) where +import qualified Relude.Unsafe as Unsafe -import Data.Bool ( bool ) import Control.Exception ( bracket ) import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State import Data.Binary.Get import Data.Binary.Put import qualified Data.ByteString import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy import Network.Socket ( SockAddr(SockAddrUnix) ) -import qualified Network.Socket +import qualified Network.Socket as S import Network.Socket.ByteString ( recv , sendAll ) @@ -122,7 +121,7 @@ simpleOp :: WorkerOp -> MonadStore Bool -simpleOp op = simpleOpArgs op $ pure () +simpleOp op = simpleOpArgs op pass simpleOpArgs :: WorkerOp -> Put -> MonadStore Bool simpleOpArgs op args = do @@ -131,19 +130,19 @@ bool sockGetBool (do - Error _num msg <- head <$> getError + Error _num msg <- Unsafe.head <$> getError throwError $ Data.ByteString.Char8.unpack msg ) err runOp :: WorkerOp -> MonadStore () -runOp op = runOpArgs op $ pure () +runOp op = runOpArgs op pass runOpArgs :: WorkerOp -> Put -> MonadStore () runOpArgs op args = runOpArgsIO op - (\encode -> encode $ Data.ByteString.Lazy.toStrict $ runPut args) + (\encode -> encode $ toStrict $ runPut args) runOpArgsIO :: WorkerOp @@ -160,7 +159,7 @@ modify (\(a, b) -> (a, b <> out)) err <- gotError when err $ do - Error _num msg <- head <$> getError + Error _num msg <- Unsafe.head <$> getError throwError $ Data.ByteString.Char8.unpack msg runStore :: MonadStore a -> IO (Either String a, [Logger]) @@ -168,17 +167,24 @@ runStoreOpts :: FilePath -> FilePath -> MonadStore a -> IO (Either String a, [Logger]) -runStoreOpts sockPath storeRootDir code = do - bracket (open sockPath) (Network.Socket.close . storeSocket) run - where - open path = do - soc <- - Network.Socket.socket - Network.Socket.AF_UNIX - Network.Socket.Stream - 0 +runStoreOpts path = runStoreOpts' S.AF_UNIX (SockAddrUnix path) - Network.Socket.connect soc (SockAddrUnix path) +runStoreOptsTCP + :: String -> Int -> FilePath -> MonadStore a -> IO (Either String a, [Logger]) +runStoreOptsTCP host port storeRootDir code = do + S.getAddrInfo (Just S.defaultHints) (Just host) (Just $ show port) >>= \case + (sockAddr:_) -> runStoreOpts' (S.addrFamily sockAddr) (S.addrAddress sockAddr) storeRootDir code + _ -> pure (Left "Couldn't resolve host and port with getAddrInfo.", []) + +runStoreOpts' + :: S.Family -> S.SockAddr -> FilePath -> MonadStore a -> IO (Either String a, [Logger]) +runStoreOpts' sockFamily sockAddr storeRootDir code = + bracket open (S.close . storeSocket) run + + where + open = do + soc <- S.socket sockFamily S.Stream 0 + S.connect soc sockAddr pure StoreConfig { storeSocket = soc , storeDir = storeRootDir @@ -190,7 +196,7 @@ vermagic <- liftIO $ recv soc 16 let (magic2, _daemonProtoVersion) = - flip runGet (Data.ByteString.Lazy.fromStrict vermagic) + flip runGet (fromStrict vermagic) $ (,) <$> (getInt :: Get Int) <*> (getInt :: Get Int) diff --git a/src/System/Nix/Store/Remote/Types.hs b/src/System/Nix/Store/Remote/Types.hs --- a/src/System/Nix/Store/Remote/Types.hs +++ b/src/System/Nix/Store/Remote/Types.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# language DataKinds #-} +{-# language KindSignatures #-} +{-# language ScopedTypeVariables #-} module System.Nix.Store.Remote.Types ( MonadStore , StoreConfig(..) @@ -18,12 +17,8 @@ where -import Data.ByteString ( ByteString ) import qualified Data.ByteString.Lazy as BSL import Network.Socket ( Socket ) -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State data StoreConfig = StoreConfig { storeDir :: FilePath @@ -61,13 +56,13 @@ isError _ = False gotError :: MonadStore Bool -gotError = any isError . snd <$> get +gotError = gets (any isError . snd) getError :: MonadStore [Logger] -getError = filter isError . snd <$> get +getError = gets (filter isError . snd) getLog :: MonadStore [Logger] -getLog = snd <$> get +getLog = gets snd flushLog :: MonadStore () flushLog = modify (\(a, _b) -> (a, [])) @@ -79,4 +74,4 @@ clearData = modify (\(_, b) -> (Nothing, b)) getStoreDir :: MonadStore FilePath -getStoreDir = storeDir <$> ask +getStoreDir = asks storeDir diff --git a/src/System/Nix/Store/Remote/Util.hs b/src/System/Nix/Store/Remote/Util.hs --- a/src/System/Nix/Store/Remote/Util.hs +++ b/src/System/Nix/Store/Remote/Util.hs @@ -1,20 +1,14 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# language RecordWildCards #-} module System.Nix.Store.Remote.Util where +import Prelude hiding ( putText ) import Control.Monad.Except -import Control.Monad.Reader -import Data.Either import Data.Binary.Get import Data.Binary.Put -import Data.Text ( Text ) -import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import Data.Time import Data.Time.Clock.POSIX -import Data.ByteString ( ByteString ) import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as BSL @@ -40,7 +34,7 @@ go (Partial k ) = do chunk <- getsome go (k chunk) - go (Fail _leftover _consumed msg) = error msg + go (Fail _leftover _consumed msg) = error $ fromString msg getSocketIncremental :: Get a -> MonadStore a getSocketIncremental = genericIncremental sockGet8 @@ -53,7 +47,7 @@ sockPut :: Put -> MonadStore () sockPut p = do soc <- asks storeSocket - liftIO $ sendAll soc $ BSL.toStrict $ runPut p + liftIO $ sendAll soc $ toStrict $ runPut p sockGet :: Get a -> MonadStore a sockGet = getSocketIncremental @@ -95,16 +89,16 @@ getSocketIncremental (getPaths sd) bsToText :: ByteString -> Text -bsToText = T.decodeUtf8 +bsToText = decodeUtf8 textToBS :: Text -> ByteString -textToBS = T.encodeUtf8 +textToBS = encodeUtf8 bslToText :: BSL.ByteString -> Text -bslToText = TL.toStrict . TL.decodeUtf8 +bslToText = toText . TL.decodeUtf8 textToBSL :: Text -> BSL.ByteString -textToBSL = TL.encodeUtf8 . TL.fromStrict +textToBSL = TL.encodeUtf8 . toLText putText :: Text -> Put putText = putByteStringLen . textToBSL @@ -120,11 +114,11 @@ Data.HashSet.fromList . rights . fmap (parsePath sd) <$> getByteStrings putPath :: StorePath -> Put -putPath = putByteStringLen . BSL.fromStrict . storePathToRawFilePath +putPath = putByteStringLen . fromStrict . storePathToRawFilePath putPaths :: StorePathSet -> Put putPaths = putByteStrings . Data.HashSet.toList . Data.HashSet.map - (BSL.fromStrict . storePathToRawFilePath) + (fromStrict . storePathToRawFilePath) putBool :: Bool -> Put putBool True = putInt (1 :: Int) @@ -170,4 +164,4 @@ putMany putText args flip putMany (Data.Map.toList env) - $ \(first, second) -> putText first >> putText second + $ \(a1, a2) -> putText a1 *> putText a2 diff --git a/tests/Derivation.hs b/tests/Derivation.hs deleted file mode 100644 --- a/tests/Derivation.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeApplications #-} - -module Derivation where - -import Control.Monad.IO.Class ( liftIO ) - -import Data.Text ( Text ) -import Nix.Derivation ( Derivation(..) - , DerivationOutput(..) - ) -import System.Nix.StorePath ( StorePath - , storePathToText - ) - -import System.Nix.Store.Remote ( MonadStore - , addToStore - , addTextToStore - ) -import qualified Data.Map -import qualified Data.Set -import qualified Data.Text -import qualified Data.Text.Lazy -import qualified Data.Text.Lazy.Builder -import qualified Data.Vector -import qualified System.Nix.Derivation -import qualified System.Nix.StorePath -import qualified System.Directory -import Crypto.Hash ( SHA256 ) - -drvSample :: StorePath -> StorePath -> StorePath -> Derivation StorePath Text -drvSample builder' buildScript out = Derivation - { outputs = Data.Map.fromList [("out", DerivationOutput out "sha256" "test")] - , inputDrvs = Data.Map.fromList [(builder', Data.Set.fromList ["out"])] - , inputSrcs = Data.Set.fromList [buildScript] - , platform = "x86_64-linux" - , builder = storePathToText builder' - , args = Data.Vector.fromList ["-e", storePathToText buildScript] - , env = Data.Map.fromList [("testEnv", "true")] - } - -withBash :: (StorePath -> MonadStore a) -> MonadStore a -withBash action = do - mfp <- liftIO $ System.Directory.findExecutable "bash" - case mfp of - Nothing -> error "No bash executable found" - Just fp -> do - let Right n = System.Nix.StorePath.makeStorePathName "bash" - pth <- addToStore @SHA256 n fp False (pure True) False - action pth - -withBuildScript :: (StorePath -> MonadStore a) -> MonadStore a -withBuildScript action = do - pth <- addTextToStore "buildScript" - (Data.Text.concat ["declare -xp", "export > $out"]) - mempty - False - - action pth - -withDerivation - :: (StorePath -> Derivation StorePath Text -> MonadStore a) -> MonadStore a -withDerivation action = withBuildScript $ \buildScript -> withBash $ \bash -> - do - outputPath <- addTextToStore "wannabe-output" "" mempty False - - let d = drvSample bash buildScript outputPath - - pth <- addTextToStore - "hnix-store-derivation" - ( Data.Text.Lazy.toStrict - $ Data.Text.Lazy.Builder.toLazyText - $ System.Nix.Derivation.buildDerivation d - ) - mempty - False - - liftIO $ print d - action pth d - diff --git a/tests/NixDaemon.hs b/tests/NixDaemon.hs --- a/tests/NixDaemon.hs +++ b/tests/NixDaemon.hs @@ -1,23 +1,14 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# language DataKinds #-} +{-# language ScopedTypeVariables #-} module NixDaemon where -import Data.Bool ( bool ) -import Control.Monad ( void ) -import Control.Monad.IO.Class ( liftIO ) +import qualified System.Environment as Env import Control.Exception ( bracket ) import Control.Concurrent ( threadDelay ) -import Data.Either ( isRight - , isLeft - ) -import Data.Text ( Text ) import qualified Data.HashSet as HS import qualified Data.Map.Strict as M import System.Directory -import qualified System.Environment import System.IO.Temp import qualified System.Process as P import System.Posix.User as U @@ -36,30 +27,30 @@ import System.Nix.Store.Remote import System.Nix.Store.Remote.Protocol -import Derivation -import Crypto.Hash ( SHA256 - ) +import Crypto.Hash ( SHA256 ) +import System.Nix.Nar ( dumpPath ) createProcessEnv :: FilePath -> String -> [String] -> IO P.ProcessHandle createProcessEnv fp proc args = do - mPath <- System.Environment.lookupEnv "PATH" + mPath <- Env.lookupEnv "PATH" (_, _, _, ph) <- P.createProcess (P.proc proc args) - { P.cwd = Just $ fp + { P.cwd = Just fp , P.env = Just $ mockedEnv mPath fp } pure ph mockedEnv :: Maybe String -> FilePath -> [(String, FilePath)] -mockedEnv mEnvPath fp = - [ ("NIX_STORE_DIR" , fp "store") - , ("NIX_LOCALSTATE_DIR", fp "var") - , ("NIX_LOG_DIR" , fp "var" "log") - , ("NIX_STATE_DIR" , fp "var" "nix") - , ("NIX_CONF_DIR" , fp "etc") +mockedEnv mEnvPath fp = (fp ) <<$>> + [ ("NIX_STORE_DIR" , "store") + , ("NIX_LOCALSTATE_DIR", "var") + , ("NIX_LOG_DIR" , "var" "log") + , ("NIX_STATE_DIR" , "var" "nix") + , ("NIX_CONF_DIR" , "etc") + , ("HOME" , "home") -- , ("NIX_REMOTE", "daemon") - ] <> (maybe [] (\x -> [("PATH", x)]) mEnvPath) + ] <> foldMap (\x -> [("PATH", x)]) mEnvPath waitSocket :: FilePath -> Int -> IO () waitSocket _ 0 = fail "No socket" @@ -67,12 +58,12 @@ ex <- doesFileExist fp bool (threadDelay 100000 >> waitSocket fp (x - 1)) - (pure ()) + pass ex writeConf :: FilePath -> IO () writeConf fp = - writeFile fp $ unlines + writeFileText fp $ unlines [ "build-users-group = " , "trusted-users = root" , "allowed-users = *" @@ -131,7 +122,7 @@ bracket (startDaemon path) (P.terminateProcess . fst) - (\x -> action . snd $ x) + (action . snd) checks :: (Show a, Show b) => IO (a, b) -> (a -> Bool) -> IO () checks action check = action >>= (`Hspec.shouldSatisfy` (check . fst)) @@ -143,7 +134,7 @@ -> (a -> Bool) -> Hspec.SpecWith (m () -> IO (a, b)) it name action check = - Hspec.it name $ \run -> (run (action >> pure ())) `checks` check + Hspec.it name $ \run -> run (action >> pass) `checks` check itRights :: (Show a, Show b, Show c, Monad m) @@ -168,8 +159,7 @@ dummy :: MonadStore StorePath dummy = do let Right n = makeStorePathName "dummy" - res <- addToStore @SHA256 n "dummy" False (pure True) False - pure res + addToStore @SHA256 n (dumpPath "dummy") False False invalidPath :: StorePath invalidPath = @@ -204,30 +194,30 @@ verifyStore True True `shouldReturn` False context "addTextToStore" $ - itRights "adds text to store" $ withPath $ const pure () + itRights "adds text to store" $ withPath pure context "isValidPathUncached" $ do itRights "validates path" $ withPath $ \path -> do - liftIO $ putStrLn $ show path - (isValidPathUncached path) `shouldReturn` True - itLefts "fails on invalid path" $ isValidPathUncached $ invalidPath + liftIO $ print path + isValidPathUncached path `shouldReturn` True + itLefts "fails on invalid path" $ isValidPathUncached invalidPath context "queryAllValidPaths" $ do - itRights "empty query" $ queryAllValidPaths + itRights "empty query" queryAllValidPaths itRights "non-empty query" $ withPath $ \path -> - queryAllValidPaths `shouldReturn` (HS.fromList [path]) + queryAllValidPaths `shouldReturn` HS.fromList [path] context "queryPathInfoUncached" $ - itRights "queries path info" $ withPath $ queryPathInfoUncached + itRights "queries path info" $ withPath queryPathInfoUncached context "ensurePath" $ - itRights "simple ensure" $ withPath $ ensurePath + itRights "simple ensure" $ withPath ensurePath context "addTempRoot" $ - itRights "simple addition" $ withPath $ addTempRoot + itRights "simple addition" $ withPath addTempRoot context "addIndirectRoot" $ - itRights "simple addition" $ withPath $ addIndirectRoot + itRights "simple addition" $ withPath addIndirectRoot context "buildPaths" $ do itRights "build Normal" $ withPath $ \path -> do @@ -243,13 +233,13 @@ buildPaths pathSet Repair context "roots" $ context "findRoots" $ do - itRights "empty roots" $ (findRoots `shouldReturn` M.empty) + itRights "empty roots" (findRoots `shouldReturn` M.empty) itRights "path added as a temp root" $ withPath $ \_ -> do roots <- findRoots roots `shouldSatisfy` ((== 1) . M.size) - context "optimiseStore" $ itRights "optimises" $ optimiseStore + context "optimiseStore" $ itRights "optimises" optimiseStore context "queryMissing" $ itRights "queries" $ withPath $ \path -> do @@ -260,7 +250,7 @@ itRights "adds file to store" $ do fp <- liftIO $ writeSystemTempFile "addition" "lal" let Right n = makeStorePathName "tmp-addition" - res <- addToStore @SHA256 n fp False (pure True) False + res <- addToStore @SHA256 n (dumpPath fp) False False liftIO $ print res context "with dummy" $ do @@ -268,11 +258,5 @@ itRights "valid dummy" $ do path <- dummy - liftIO $ putStrLn $ show path - (isValidPathUncached path) `shouldReturn` True - - context "derivation" $ - itRights "build derivation" $ - withDerivation $ \path drv -> do - result <- buildDerivation path drv Normal - result `shouldSatisfy` ((== AlreadyValid) . status) + liftIO $ print path + isValidPathUncached path `shouldReturn` True diff --git a/tests/Util.hs b/tests/Util.hs --- a/tests/Util.hs +++ b/tests/Util.hs @@ -1,7 +1,7 @@ module Util where -import Data.Text.Arbitrary +import Data.Text.Arbitrary () import System.Nix.Store.Remote.Util import Test.Tasty.QuickCheck