haskell-nix/hnix-store
1
1
Fork 0
mirror of https://github.com/haskell-nix/hnix-store.git synced 2024-12-12 08:07:39 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #231 from sorki/srk/cereal

Browse Source 
remote: start transitioning from binary to cereal
This commit is contained in:
Richard Marko 2023-11-17 13:08:07 +01:00 committed by GitHub
commit 3b06982717
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
31 changed files with 919 additions and 273 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
cabal.project
View File

@ -1 +1,7 @@
packages: ./hnix-store-core/*.cabal ./hnix-store-remote/*.cabal
packages:
./hnix-store-core/hnix-store-core.cabal
./hnix-store-remote/hnix-store-remote.cabal
package hnix-store-remote
flags: +build-readme +io-testsuite

2
cabal.project.local.ci
View File

@ -1,7 +1,5 @@
tests: True
flags: +io-testsuite
package hnix-store-core
ghc-options: -Wunused-packages -Wall

16
hnix-store-core/CHANGELOG.md
View File

@ -1,16 +1,32 @@
# Next
* Changes:
* `StorePathMetadata` converted to `Metadata a` [#231](https://github.com/haskell-nix/hnix-store/pull/231)
* Constructors of `StorePathName` and `StorePathHashPart` are no longer
exported. Use respective `mkStorePath..` functions. [#230](https://github.com/haskell-nix/hnix-store/pull/230)
* `StorePathSet` type alias is no more, use `HashSet StorePath` [#230](https://github.com/haskell-nix/hnix-store/pull/230)
* `makeStorePath` and `parsePath` now returns `Either InvalidPathError StorePath` [#231](https://github.com/haskell-nix/hnix-store/pull/231)
* `BuildResult`s `timesBuild` field changes type from `Integer` to `Int` [#231](https://github.com/haskell-nix/hnix-store/pull/231)
* Additions:
* `Default StoreDir` instance [#231](https://github.com/haskell-nix/hnix-store/pull/231)
* `System.Nix.StorePath.storePathHashPartToText` [#231](https://github.com/haskell-nix/hnix-store/pull/231)
* Added `Generic` and `Show` instances for
`Signature` and `NarSignature` [#231](https://github.com/haskell-nix/hnix-store/pull/231)
* Added `Eq` and `Ord` instances for `SomeNamedDigest` [#231](https://github.com/haskell-nix/hnix-store/pull/231)
* `BuildStatus` grows `NoSubstituters` and `ResolvesToAlreadyValid` constructors [#231](https://github.com/haskell-nix/hnix-store/pull/231)
* `InvalidPathError` replacing previous stringy error [#231](https://github.com/haskell-nix/hnix-store/pull/231)
* Added `Arbitrary` instances for (exported by default) [#230](https://github.com/haskell-nix/hnix-store/pull/230)
* `StorePath`
* `StorePathName`
* `StorePathHashPart`
* `StoreDir`
* Added `Arbitrary` instances for [#231](https://github.com/haskell-nix/hnix-store/pull/231)
* `BuildMode`
* `BuildStatus`
* `BuildResult`
* `Derivation StorePath Text`
* `DerivationOutput StorePath Text`
# [0.7.0.0](https://github.com/haskell-nix/hnix-store/compare/core-0.6.1.0...core-0.7.0.0) 2023-11-15

1
hnix-store-core/cabal.project
View File

@ -1 +0,0 @@
packages: .

10
hnix-store-core/hnix-store-core.cabal
View File

@ -60,6 +60,8 @@ library
, case-insensitive
, cereal
, containers
, data-default-class
, generic-arbitrary < 1.1
-- Required for cryptonite low-level type convertion
, memory
, cryptonite
@ -71,6 +73,7 @@ library
, mtl
, nix-derivation >= 1.1.1 && <2
, QuickCheck
, quickcheck-instances
, saltine
, time
, text
@ -89,9 +92,13 @@ library
, DeriveFoldable
, DeriveTraversable
, DeriveLift
, DerivingStrategies
, DerivingVia
, FlexibleContexts
, FlexibleInstances
, StandaloneDeriving
, ScopedTypeVariables
, RecordWildCards
, TypeApplications
, TypeSynonymInstances
, InstanceSigs
@ -116,6 +123,7 @@ test-suite format-tests
main-is: Driver.hs
other-modules:
Derivation
ContentAddressableAddress
NarFormat
Hash
StorePath
@ -134,9 +142,11 @@ test-suite format-tests
, bytestring
, containers
, cryptonite
, data-default-class
, directory
, filepath
, process
, nix-derivation >= 1.1.1 && <2
, tasty
, tasty-golden
, hspec

23
hnix-store-core/src/System/Nix/Build.hs
View File

@ -1,4 +1,5 @@
{-# language RecordWildCards #-}
-- due to recent generic-arbitrary
{-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-}
{-|
Description : Build related types
Maintainer : srk <srk@48.io>
@ -8,15 +9,18 @@ module System.Nix.Build
, BuildStatus(..)
, BuildResult(..)
, buildSuccess
)
where
) where
import Data.Time (UTCTime)
import Test.QuickCheck (Arbitrary(..))
import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..))
import Test.QuickCheck.Instances ()
-- keep the order of these Enums to match enums from reference implementations
-- src/libstore/store-api.hh
data BuildMode = Normal | Repair | Check
deriving (Eq, Ord, Enum, Show)
deriving (Eq, Generic, Ord, Enum, Show)
deriving Arbitrary via GenericArbitrary BuildMode
data BuildStatus =
Built
@ -32,8 +36,10 @@ data BuildStatus =
| DependencyFailed
| LogLimitExceeded
| NotDeterministic
deriving (Eq, Ord, Enum, Show)
| ResolvesToAlreadyValid
| NoSubstituters
deriving (Eq, Generic, Ord, Enum, Show)
deriving Arbitrary via GenericArbitrary BuildStatus
-- | Result of the build
data BuildResult = BuildResult
@ -42,7 +48,7 @@ data BuildResult = BuildResult
, -- | possible build error message
errorMessage :: !(Maybe Text)
, -- | How many times this build was performed
timesBuilt :: !Integer
timesBuilt :: !Int
, -- | If timesBuilt > 1, whether some builds did not produce the same result
isNonDeterministic :: !Bool
, -- Start time of this build
@ -50,7 +56,8 @@ data BuildResult = BuildResult
, -- Stop time of this build
stopTime :: !UTCTime
}
deriving (Eq, Ord, Show)
deriving (Eq, Generic, Ord, Show)
deriving Arbitrary via GenericArbitrary BuildResult
buildSuccess :: BuildResult -> Bool
buildSuccess BuildResult {..} =

56
hnix-store-core/src/System/Nix/Derivation.hs
View File

@ -1,32 +1,48 @@
-- due to recent generic-arbitrary
{-# OPTIONS_GHC -Wno-orphans -fconstraint-solver-iterations=0 #-}
module System.Nix.Derivation
( parseDerivation
, buildDerivation
)
where
) where
import qualified Data.Text.Lazy.Builder as Text.Lazy
( Builder )
import qualified Data.Attoparsec.Text.Lazy as Text.Lazy
( Parser )
import Nix.Derivation ( Derivation )
import qualified Nix.Derivation as Derivation
import System.Nix.StorePath ( StoreDir
, StorePath
, storePathToFilePath
)
import qualified System.Nix.StorePath as StorePath
import Data.Attoparsec.Text.Lazy (Parser)
import Data.Text.Lazy.Builder (Builder)
import Test.QuickCheck (Arbitrary(..))
import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..))
import Test.QuickCheck.Instances ()
import Nix.Derivation (Derivation, DerivationOutput)
import System.Nix.StorePath (StoreDir, StorePath)
import qualified Data.Attoparsec.Text.Lazy
import qualified Data.Text.Lazy
parseDerivation :: StoreDir -> Text.Lazy.Parser (Derivation StorePath Text)
import qualified Nix.Derivation
import qualified System.Nix.StorePath
deriving via GenericArbitrary (Derivation StorePath Text)
instance Arbitrary (Derivation StorePath Text)
deriving via GenericArbitrary (DerivationOutput StorePath Text)
instance Arbitrary (DerivationOutput StorePath Text)
parseDerivation :: StoreDir -> Parser (Derivation StorePath Text)
parseDerivation expectedRoot =
Derivation.parseDerivationWith
("\"" *> StorePath.pathParser expectedRoot <* "\"")
Derivation.textParser
Nix.Derivation.parseDerivationWith
pathParser
Nix.Derivation.textParser
where
pathParser = do
text <- Nix.Derivation.textParser
case Data.Attoparsec.Text.Lazy.parseOnly
(System.Nix.StorePath.pathParser expectedRoot)
(Data.Text.Lazy.fromStrict text)
of
Right p -> pure p
Left e -> fail e
buildDerivation :: StoreDir -> Derivation StorePath Text -> Text.Lazy.Builder
buildDerivation :: StoreDir -> Derivation StorePath Text -> Builder
buildDerivation storeDir =
Derivation.buildDerivationWith
(show . storePathToFilePath storeDir)
Nix.Derivation.buildDerivationWith
(show . System.Nix.StorePath.storePathToText storeDir)
show

17
hnix-store-core/src/System/Nix/Internal/Hash.hs
View File

@ -19,6 +19,7 @@ module System.Nix.Internal.Hash
)
where
import Crypto.Hash (Digest)
import qualified Text.Show
import qualified Crypto.Hash as C
import qualified Data.ByteString as BS
@ -45,11 +46,23 @@ instance NamedAlgo C.SHA512 where
algoName = "sha512"
-- | A digest whose 'NamedAlgo' is not known at compile time.
data SomeNamedDigest = forall a . NamedAlgo a => SomeDigest (C.Digest a)
data SomeNamedDigest = forall a . NamedAlgo a => SomeDigest (Digest a)
instance Show SomeNamedDigest where
show sd = case sd of
SomeDigest (digest :: C.Digest hashType) -> toString $ "SomeDigest " <> algoName @hashType <> ":" <> encodeDigestWith NixBase32 digest
SomeDigest (digest :: Digest hashType) -> toString $ "SomeDigest " <> algoName @hashType <> ":" <> encodeDigestWith NixBase32 digest
instance Eq SomeNamedDigest where
(==) (SomeDigest (a :: Digest aType))
(SomeDigest (b :: Digest bType))
= algoName @aType == algoName @bType
&& encodeDigestWith NixBase32 a == encodeDigestWith NixBase32 b
instance Ord SomeNamedDigest where
(<=) (SomeDigest (a :: Digest aType))
(SomeDigest (b :: Digest bType))
= algoName @aType <= algoName @bType
&& encodeDigestWith NixBase32 a <= encodeDigestWith NixBase32 b
mkNamedDigest :: Text -> Text -> Either String SomeNamedDigest
mkNamedDigest name sriHash =

11
hnix-store-core/src/System/Nix/Internal/Nar/Parser.hs
View File

@ -47,7 +47,7 @@ import qualified System.Nix.Internal.Nar.Options as Nar
-- of the actions the parser can take, and @ParserState@ for the
-- internals of the parser
newtype NarParser m a = NarParser
{ runNarParser ::
{ _runNarParser ::
State.StateT
ParserState
(Except.ExceptT
@ -554,15 +554,12 @@ testParser' :: (m ~ IO) => FilePath -> IO (Either String ())
testParser' fp =
withFile fp ReadMode $ \h -> runParser Nar.narEffectsIO parseNar h "tmp"
-- | Distance to the next multiple of 8
padLen :: Int -> Int
padLen n = (8 - n) `mod` 8
dbgState :: IO.MonadIO m => NarParser m ()
dbgState = do
-- | Debugging helper
_dbgState :: IO.MonadIO m => NarParser m ()
_dbgState = do
s <- State.get
IO.liftIO $ print (tokenStack s, directoryStack s)

4
hnix-store-core/src/System/Nix/Internal/Signature.hs
View File

@ -23,7 +23,7 @@ import qualified Crypto.Saltine.Internal.ByteSizes as NaClSizes
-- | A NaCl signature.
newtype Signature = Signature ByteString
deriving (Eq, Ord)
deriving (Eq, Generic, Ord, Show)
instance IsEncoding Signature where
decode s
@ -42,4 +42,4 @@ data NarSignature = NarSignature
, -- | The archive's signature.
sig :: Signature
}
deriving (Eq, Ord)
deriving (Eq, Generic, Ord, Show)

159
hnix-store-core/src/System/Nix/Internal/StorePath.hs
View File

@ -1,10 +1,9 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-|
Description : Representation of Nix store paths.
-}
{-# language ConstraintKinds #-}
{-# language RecordWildCards #-}
{-# language GeneralizedNewtypeDeriving #-}
{-# language ScopedTypeVariables #-}
{-# language DeriveAnyClass #-}
{-# language AllowAmbiguousTypes #-}
{-# language DataKinds #-}
@ -16,22 +15,31 @@ module System.Nix.Internal.StorePath
, StorePathHashPart(..)
, mkStorePathHashPart
, ContentAddressableAddress(..)
, contentAddressableAddressBuilder
, contentAddressableAddressParser
, digestBuilder
, NarHashMode(..)
, -- * Manipulating 'StorePathName'
makeStorePathName
, validStorePathName
-- * Reason why a path is not valid
, InvalidPathError(..)
, -- * Rendering out 'StorePath's
storePathToFilePath
, storePathToRawFilePath
, storePathToText
, storePathToNarInfo
, storePathHashPartToText
, -- * Parsing 'StorePath's
parsePath
, pathParser
)
where
import Data.Default.Class (Default(def))
import Data.Text.Lazy.Builder (Builder)
import qualified Relude.Unsafe as Unsafe
import qualified System.Nix.Hash
import System.Nix.Internal.Hash
import System.Nix.Internal.Base
import qualified System.Nix.Internal.Base32 as Nix.Base32
@ -39,17 +47,23 @@ import qualified System.Nix.Internal.Base32 as Nix.Base32
import qualified Data.ByteString.Char8 as Bytes.Char8
import qualified Data.Char as Char
import qualified Data.Text as Text
import qualified Data.Text.Encoding
import qualified Data.Text.Lazy.Builder
import Data.Attoparsec.Text.Lazy ( Parser
, (<?>)
)
import qualified Data.Attoparsec.ByteString.Char8
import qualified Data.Attoparsec.Text.Lazy as Parser.Text.Lazy
import qualified System.FilePath as FilePath
import Crypto.Hash ( SHA256
, Digest
, HashAlgorithm
, hash
)
import Test.QuickCheck
import Test.QuickCheck (Arbitrary(arbitrary), listOf, elements)
import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..))
import Test.QuickCheck.Instances ()
-- | A path in a Nix store.
--
@ -68,7 +82,7 @@ data StorePath = StorePath
-- hello-1.2.3).
storePathName :: !StorePathName
}
deriving (Eq, Ord, Show)
deriving (Eq, Generic, Ord, Show)
instance Hashable StorePath where
hashWithSalt s StorePath{..} =
@ -88,7 +102,7 @@ instance Arbitrary StorePath where
newtype StorePathName = StorePathName
{ -- | Extract the contents of the name.
unStorePathName :: Text
} deriving (Eq, Hashable, Ord, Show)
} deriving (Eq, Generic, Hashable, Ord, Show)
instance Arbitrary StorePathName where
arbitrary = StorePathName . toText <$> ((:) <$> s1 <*> listOf sn)
@ -102,7 +116,7 @@ newtype StorePathHashPart = StorePathHashPart
{ -- | Extract the contents of the hash.
unStorePathHashPart :: ByteString
}
deriving (Eq, Hashable, Ord, Show)
deriving (Eq, Generic, Hashable, Ord, Show)
instance Arbitrary StorePathHashPart where
arbitrary = mkStorePathHashPart @SHA256 . Bytes.Char8.pack <$> arbitrary
@ -112,8 +126,9 @@ mkStorePathHashPart
. HashAlgorithm hashAlgo
=> ByteString
-> StorePathHashPart
mkStorePathHashPart = coerce . mkStorePathHash @hashAlgo
mkStorePathHashPart = StorePathHashPart . mkStorePathHash @hashAlgo
-- TODO(srk): split into its own module + .Builder/.Parser
-- | An address for a content-addressable store path, i.e. one whose
-- store path hash is purely a function of its contents (as opposed to
-- paths that are derivation outputs, whose hashes are a function of
@ -132,6 +147,67 @@ data ContentAddressableAddress
-- addToStore. It is addressed according to some hash algorithm
-- applied to the nar serialization via some 'NarHashMode'.
Fixed !NarHashMode !SomeNamedDigest
deriving (Eq, Generic, Ord, Show)
-- TODO(srk): extend to all hash types
instance Arbitrary (Digest SHA256) where
arbitrary = hash @ByteString <$> arbitrary
instance Arbitrary SomeNamedDigest where
arbitrary = SomeDigest @SHA256 <$> arbitrary
deriving via GenericArbitrary ContentAddressableAddress
instance Arbitrary ContentAddressableAddress
-- | Builder for `ContentAddressableAddress`
contentAddressableAddressBuilder :: ContentAddressableAddress -> Builder
contentAddressableAddressBuilder (Text digest) =
"text:"
<> digestBuilder digest
contentAddressableAddressBuilder (Fixed narHashMode (SomeDigest (digest :: Digest hashAlgo))) =
"fixed:"
<> (if narHashMode == Recursive then "r:" else mempty)
-- <> Data.Text.Lazy.Builder.fromText (System.Nix.Hash.algoName @hashAlgo)
<> digestBuilder digest
-- | Builder for @Digest@s
digestBuilder :: forall hashAlgo . (NamedAlgo hashAlgo) => Digest hashAlgo -> Builder
digestBuilder digest =
Data.Text.Lazy.Builder.fromText (System.Nix.Hash.algoName @hashAlgo)
<> ":"
<> Data.Text.Lazy.Builder.fromText (encodeDigestWith NixBase32 digest)
-- | Parser for content addressable field
contentAddressableAddressParser :: Data.Attoparsec.ByteString.Char8.Parser ContentAddressableAddress
contentAddressableAddressParser = caText <|> caFixed
where
-- | Parser for @text:sha256:<h>@
--caText :: Parser ContentAddressableAddress
caText = do
_ <- "text:sha256:"
digest <- decodeDigestWith @SHA256 NixBase32 <$> parseHash
either fail pure $ Text <$> digest
-- | Parser for @fixed:<r?>:<ht>:<h>@
--caFixed :: Parser ContentAddressableAddress
caFixed = do
_ <- "fixed:"
narHashMode <- (Recursive <$ "r:") <|> (RegularFile <$ "")
digest <- parseTypedDigest
either fail pure $ Fixed narHashMode <$> digest
--parseTypedDigest :: Parser (Either String SomeNamedDigest)
parseTypedDigest = mkNamedDigest <$> parseHashType <*> parseHash
--parseHashType :: Parser Text
parseHashType =
Data.Text.Encoding.decodeUtf8
<$> ("sha256" <|> "sha512" <|> "sha1" <|> "md5") <* (":" <|> "-")
--parseHash :: Parser Text
parseHash =
Data.Text.Encoding.decodeUtf8
<$> Data.Attoparsec.ByteString.Char8.takeWhile1 (/= ':')
-- | Schemes for hashing a Nix archive.
--
@ -143,19 +219,36 @@ data NarHashMode
| -- | Hash an arbitrary nar, including a non-executable regular
-- file if so desired.
Recursive
deriving (Eq, Enum, Generic, Hashable, Ord, Show)
makeStorePathName :: Text -> Either String StorePathName
deriving via GenericArbitrary NarHashMode
instance Arbitrary NarHashMode
-- | Reason why a path is not valid
data InvalidPathError =
EmptyName
| PathTooLong
| LeadingDot
| InvalidCharacter
| HashDecodingFailure String
| RootDirMismatch
{ rdMismatchExpected :: StoreDir
, rdMismatchGot :: StoreDir
}
deriving (Eq, Generic, Hashable, Ord, Show)
makeStorePathName :: Text -> Either InvalidPathError StorePathName
makeStorePathName n =
if validStorePathName n
then pure $ StorePathName n
else Left $ reasonInvalid n
reasonInvalid :: Text -> String
reasonInvalid :: Text -> InvalidPathError
reasonInvalid n
| n == "" = "Empty name"
| Text.length n > 211 = "Path too long"
| Text.head n == '.' = "Leading dot"
| otherwise = "Invalid character"
| n == "" = EmptyName
| Text.length n > 211 = PathTooLong
| Text.head n == '.' = LeadingDot
| otherwise = InvalidCharacter
validStorePathName :: Text -> Bool
validStorePathName n =
@ -183,17 +276,20 @@ type RawFilePath = ByteString
-- do not know their own store dir by design.
newtype StoreDir = StoreDir {
unStoreDir :: RawFilePath
} deriving (Eq, Hashable, Ord, Show)
} deriving (Eq, Generic, Hashable, Ord, Show)
instance Arbitrary StoreDir where
arbitrary = StoreDir . ("/" <>) . Bytes.Char8.pack <$> arbitrary
instance Default StoreDir where
def = StoreDir "/nix/store"
-- | Render a 'StorePath' as a 'RawFilePath'.
storePathToRawFilePath :: StoreDir -> StorePath -> RawFilePath
storePathToRawFilePath storeDir StorePath{..} =
unStoreDir storeDir <> "/" <> hashPart <> "-" <> name
where
hashPart = encodeUtf8 $ encodeWith NixBase32 $ coerce storePathHash
hashPart = encodeUtf8 $ storePathHashPartToText storePathHash
name = encodeUtf8 $ unStorePathName storePathName
-- | Render a 'StorePath' as a 'FilePath'.
@ -210,14 +306,26 @@ storePathToNarInfo :: StorePath -> Bytes.Char8.ByteString
storePathToNarInfo StorePath{..} =
encodeUtf8 $ encodeWith NixBase32 (coerce storePathHash) <> ".narinfo"
-- | Render a 'StorePathHashPart' as a 'Text'.
-- This is used by remote store / database
-- via queryPathFromHashPart
storePathHashPartToText :: StorePathHashPart -> Text
storePathHashPartToText = encodeWith NixBase32 . unStorePathHashPart
-- | Parse `StorePath` from `Bytes.Char8.ByteString`, checking
-- that store directory matches `expectedRoot`.
parsePath :: StoreDir -> Bytes.Char8.ByteString -> Either String StorePath
parsePath
:: StoreDir
-> Bytes.Char8.ByteString
-> Either InvalidPathError StorePath
parsePath expectedRoot x =
let
(rootDir, fname) = FilePath.splitFileName . Bytes.Char8.unpack $ x
(storeBasedHashPart, namePart) = Text.breakOn "-" $ toText fname
storeHash = decodeWith NixBase32 storeBasedHashPart
hashPart = bimap
HashDecodingFailure
StorePathHashPart
$ decodeWith NixBase32 storeBasedHashPart
name = makeStorePathName . Text.drop 1 $ namePart
--rootDir' = dropTrailingPathSeparator rootDir
-- cannot use ^^ as it drops multiple slashes /a/b/// -> /a/b
@ -226,9 +334,12 @@ parsePath expectedRoot x =
storeDir =
if expectedRootS == rootDir'
then pure rootDir'
else Left $ "Root store dir mismatch, expected" <> expectedRootS <> "got" <> rootDir'
else Left $ RootDirMismatch
{ rdMismatchExpected = expectedRoot
, rdMismatchGot = StoreDir $ Bytes.Char8.pack rootDir
}
in
either Left (pure $ StorePath <$> coerce storeHash <*> name) storeDir
either Left (pure $ StorePath <$> hashPart <*> name) storeDir
pathParser :: StoreDir -> Parser StorePath
pathParser expectedRoot = do
@ -257,8 +368,12 @@ pathParser expectedRoot = do
<?> "Path name contains invalid character"
let name = makeStorePathName $ Text.cons c0 rest
hashPart = bimap
HashDecodingFailure
StorePathHashPart
digest
either
fail
(fail . show)
pure
(StorePath <$> coerce digest <*> name)
(StorePath <$> hashPart <*> name)

6
hnix-store-core/src/System/Nix/StorePath.hs
View File

@ -10,16 +10,22 @@ module System.Nix.StorePath
, mkStorePathHashPart
, unStorePathHashPart
, ContentAddressableAddress(..)
, contentAddressableAddressBuilder
, contentAddressableAddressParser
, digestBuilder
, NarHashMode(..)
, -- * Manipulating 'StorePathName'
makeStorePathName
, unStorePathName
, validStorePathName
-- * Reason why a path is not valid
, InvalidPathError(..)
, -- * Rendering out 'StorePath's
storePathToFilePath
, storePathToRawFilePath
, storePathToText
, storePathToNarInfo
, storePathHashPartToText
, -- * Parsing 'StorePath's
parsePath
, pathParser

28
hnix-store-core/src/System/Nix/StorePathMetadata.hs
View File

@ -1,27 +1,29 @@
{-|
Description : Metadata about Nix store paths.
-}
module System.Nix.StorePathMetadata where
module System.Nix.StorePathMetadata
( Metadata(..)
, StorePathTrust(..)
) where
import System.Nix.StorePath ( StorePath
, ContentAddressableAddress
)
import System.Nix.Hash ( SomeNamedDigest )
import Data.Time (UTCTime)
import System.Nix.Signature ( NarSignature )
-- | Metadata about a 'StorePath'
data StorePathMetadata = StorePathMetadata
import System.Nix.Hash (SomeNamedDigest)
import System.Nix.Signature (NarSignature)
import System.Nix.StorePath (ContentAddressableAddress)
-- | Metadata (typically about a 'StorePath')
data Metadata a = Metadata
{ -- | The path this metadata is about
path :: !StorePath
path :: !a
, -- | The path to the derivation file that built this path, if any
-- and known.
deriverPath :: !(Maybe StorePath)
deriverPath :: !(Maybe a)
, -- TODO should this be optional?
-- | The hash of the nar serialization of the path.
narHash :: !SomeNamedDigest
, -- | The paths that this path directly references
references :: !(HashSet StorePath)
references :: !(HashSet a)
, -- | When was this path registered valid in the store?
registrationTime :: !UTCTime
, -- | The size of the nar serialization of the path, in bytes.
@ -38,7 +40,7 @@ data StorePathMetadata = StorePathMetadata
-- There is no guarantee from this type alone that this address
-- is actually correct for this store path.
contentAddressableAddress :: !(Maybe ContentAddressableAddress)
}
} deriving (Eq, Generic, Ord, Show)
-- | How much do we trust the path, based on its provenance?
data StorePathTrust
@ -47,4 +49,4 @@ data StorePathTrust
| -- | It was built elsewhere (and substituted or similar) and so
-- is less trusted
BuiltElsewhere
deriving (Show, Eq, Ord)
deriving (Eq, Enum, Generic, Ord, Show)

21
hnix-store-core/tests/ContentAddressableAddress.hs Normal file
View File

@ -0,0 +1,21 @@
module ContentAddressableAddress where
import Test.Tasty.QuickCheck
import System.Nix.StorePath (ContentAddressableAddress, contentAddressableAddressBuilder, contentAddressableAddressParser)
import qualified Data.Attoparsec.ByteString.Char8
import qualified Data.Text.Lazy
import qualified Data.Text.Lazy.Builder
import qualified Data.Text.Encoding
prop_caAddrRoundTrip :: ContentAddressableAddress -> Property
prop_caAddrRoundTrip = \caAddr ->
Data.Attoparsec.ByteString.Char8.parseOnly contentAddressableAddressParser
( Data.Text.Encoding.encodeUtf8
. Data.Text.Lazy.toStrict
. Data.Text.Lazy.Builder.toLazyText
$ contentAddressableAddressBuilder caAddr
)
=== pure caAddr

24
hnix-store-core/tests/Derivation.hs
View File

@ -5,14 +5,18 @@ import Test.Tasty ( TestTree
, testGroup
)
import Test.Tasty.Golden ( goldenVsFile )
import Test.Tasty.QuickCheck
import System.Nix.StorePath ( StoreDir(..) )
import Nix.Derivation ( Derivation )
import System.Nix.StorePath ( StoreDir(..), StorePath )
import System.Nix.Derivation ( parseDerivation
, buildDerivation
)
import Data.Default.Class (Default(def))
import qualified Data.Attoparsec.Text
import qualified Data.Text.IO
import qualified Data.Text.Lazy
import qualified Data.Text.Lazy.Builder
processDerivation :: FilePath -> FilePath -> IO ()
@ -24,10 +28,10 @@ processDerivation source dest = do
(Data.Text.IO.writeFile dest
. toText
. Data.Text.Lazy.Builder.toLazyText
. buildDerivation (StoreDir "/nix/store")
. buildDerivation def
)
(Data.Attoparsec.Text.parseOnly
(parseDerivation $ StoreDir "/nix/store")
(parseDerivation def)
contents
)
@ -46,3 +50,17 @@ test_derivation =
drv = fp <> show n <> ".drv"
act = fp <> show n <> ".actual"
fp = "tests/samples/example"
-- TODO(srk): this won't roundtrip as Arbitrary Text
-- contains wild stuff like control characters and UTF8 sequences.
-- Either fix in nix-derivation or use wrapper type
-- (but we use Nix.Derivation.textParser so we need Text for now)
xprop_derivationRoundTrip :: StoreDir -> Derivation StorePath Text -> Property
xprop_derivationRoundTrip = \sd drv ->
Data.Attoparsec.Text.parseOnly (parseDerivation sd)
( Data.Text.Lazy.toStrict
$ Data.Text.Lazy.Builder.toLazyText
$ buildDerivation sd drv
)
=== pure drv

6
hnix-store-core/tests/NarFormat.hs
View File

@ -561,16 +561,16 @@ sampleLinkToDirectoryBaseline = B64.decodeLenient $ BSL.concat
getBigFileSize :: IO Int64
getBigFileSize = fromMaybe 5000000 . readMaybe <$> (getEnv "HNIX_BIG_FILE_SIZE" <|> pure "")
-- TODO: implement and use in generator #232
-- | Add a link to a FileSystemObject. This is useful
-- when creating Arbitrary FileSystemObjects. It
-- isn't implemented yet
mkLink
_mkLink
:: FilePath -- ^ Target
-> FilePath -- ^ Link
-> FileSystemObject -- ^ FileSystemObject to add link to
-> FileSystemObject
mkLink = undefined -- TODO
_mkLink = undefined
mkBigFile :: FilePath -> IO ()
mkBigFile path = do

1
hnix-store-remote/cabal.project
View File

@ -1 +0,0 @@
packages: .

69
hnix-store-remote/hnix-store-remote.cabal
View File

@ -42,6 +42,14 @@ common commons
, LambdaCase
, BangPatterns
, ViewPatterns
build-depends:
base >=4.12 && <5
default-language: Haskell2010
common tests
import: commons
build-tool-depends:
tasty-discover:tasty-discover
flag io-testsuite
default:
@ -52,7 +60,7 @@ flag io-testsuite
flag build-readme
default:
True
False
description:
Build README.lhs example
@ -61,21 +69,21 @@ library
exposed-modules:
System.Nix.Store.Remote
, System.Nix.Store.Remote.Binary
, System.Nix.Store.Remote.Builders
, System.Nix.Store.Remote.Serialize
, System.Nix.Store.Remote.Serialize.Prim
, System.Nix.Store.Remote.Logger
, System.Nix.Store.Remote.Parsers
, System.Nix.Store.Remote.Protocol
, System.Nix.Store.Remote.Types
, System.Nix.Store.Remote.Util
build-depends:
base >=4.12 && <5
, relude >= 1.0
, attoparsec
, binary
, bytestring
, cereal
, containers
, cryptonite
, data-default-class
, text
, time
, network
@ -84,15 +92,13 @@ library
, unordered-containers
, hnix-store-core >= 0.7 && <0.8
, transformers
mixins:
base hiding (Prelude)
, relude (Relude as Prelude)
, relude
, vector
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
executable remote-readme
if !flag(build-readme)
buildable: False
build-depends:
base >=4.12 && <5
, hnix-store-remote
@ -102,45 +108,58 @@ executable remote-readme
main-is: README.lhs
ghc-options: -pgmL markdown-unlit -Wall
test-suite remote
import: tests
type: exitcode-stdio-1.0
main-is: Driver.hs
hs-source-dirs: tests
ghc-options: -Wall
other-modules:
SerializeSpec
build-depends:
hnix-store-core
, hnix-store-remote
, nix-derivation
, bytestring
, cereal
, text
, time
, hspec
, tasty
, tasty-hspec
, tasty-quickcheck
, quickcheck-instances
, unordered-containers
test-suite remote-io
import: commons
import: tests
if !flag(io-testsuite) || os(darwin)
buildable: False
type: exitcode-stdio-1.0
main-is: Driver.hs
hs-source-dirs: tests-io
-- See https://github.com/redneb/hs-linux-namespaces/issues/3
ghc-options: -rtsopts -fprof-auto "-with-rtsopts -V0"
other-modules:
NixDaemon
, Spec
hs-source-dirs: tests-io
build-depends:
base
, bytestring
, relude
, hnix-store-core >= 0.3
hnix-store-core
, hnix-store-remote
, bytestring
, containers
, cryptonite
, directory
, process
, filepath
, hspec-expectations-lifted
, quickcheck-text
, text
, tasty
, hspec
, tasty-hspec
, tasty-quickcheck
, linux-namespaces
, temporary
, unix
, unordered-containers
build-tool-depends:
tasty-discover:tasty-discover
mixins:
base hiding (Prelude)
, relude (Relude as Prelude)
, relude
default-language: Haskell2010

64
hnix-store-remote/src/System/Nix/Store/Remote.hs
View File

@ -35,7 +35,13 @@ module System.Nix.Store.Remote
)
where
import Prelude hiding ( putText )
import Data.HashSet (HashSet)
import Data.Map (Map)
import Data.Text (Text)
import qualified Control.Monad
import qualified Data.Attoparsec.ByteString.Char8
import qualified Data.Text.Encoding
--
import qualified Data.ByteString.Lazy as BSL
import Nix.Derivation ( Derivation )
@ -50,18 +56,17 @@ import System.Nix.Hash ( NamedAlgo(..)
import System.Nix.StorePath ( StorePath
, StorePathName
, StorePathHashPart
, InvalidPathError
)
import System.Nix.StorePathMetadata ( StorePathMetadata(..)
import System.Nix.StorePathMetadata ( Metadata(..)
, StorePathTrust(..)
)
import System.Nix.Internal.Base ( encodeWith )
import qualified Data.Binary.Put
import qualified Data.Map.Strict
import qualified Data.Set
import qualified System.Nix.StorePath
import qualified System.Nix.Store.Remote.Parsers
import System.Nix.Store.Remote.Binary
import System.Nix.Store.Remote.Types
@ -81,11 +86,11 @@ addToStore
-> RepairFlag -- ^ Only used by local store backend
-> MonadStore StorePath
addToStore name source recursive repair = do
when (unRepairFlag repair)
Control.Monad.when (unRepairFlag repair)
$ error "repairing is not supported when building through the Nix daemon"
runOpArgsIO AddToStore $ \yield -> do
yield $ toStrict $ Data.Binary.Put.runPut $ do
yield $ BSL.toStrict $ Data.Binary.Put.runPut $ do
putText $ System.Nix.StorePath.unStorePathName name
putBool $ not $ System.Nix.Hash.algoName @a == "sha256" && (unRecursive recursive)
putBool (unRecursive recursive)
@ -104,7 +109,7 @@ addTextToStore
-> RepairFlag -- ^ Repair flag, must be `False` in case of remote backend
-> MonadStore StorePath
addTextToStore name text references' repair = do
when (unRepairFlag repair)
Control.Monad.when (unRepairFlag repair)
$ error "repairing is not supported when building through the Nix daemon"
storeDir <- getStoreDir
@ -117,14 +122,14 @@ addTextToStore name text references' repair = do
addSignatures :: StorePath -> [BSL.ByteString] -> MonadStore ()
addSignatures p signatures = do
storeDir <- getStoreDir
void $ simpleOpArgs AddSignatures $ do
Control.Monad.void $ simpleOpArgs AddSignatures $ do
putPath storeDir p
putByteStrings signatures
addIndirectRoot :: StorePath -> MonadStore ()
addIndirectRoot pn = do
storeDir <- getStoreDir
void $ simpleOpArgs AddIndirectRoot $ putPath storeDir pn
Control.Monad.void $ simpleOpArgs AddIndirectRoot $ putPath storeDir pn
-- | Add temporary garbage collector root.
--
@ -132,7 +137,7 @@ addIndirectRoot pn = do
addTempRoot :: StorePath -> MonadStore ()
addTempRoot pn = do
storeDir <- getStoreDir
void $ simpleOpArgs AddTempRoot $ putPath storeDir pn
Control.Monad.void $ simpleOpArgs AddTempRoot $ putPath storeDir pn
-- | Build paths if they are an actual derivations.
--
@ -140,7 +145,7 @@ addTempRoot pn = do
buildPaths :: HashSet StorePath -> BuildMode -> MonadStore ()
buildPaths ps bm = do
storeDir <- getStoreDir
void $ simpleOpArgs BuildPaths $ do
Control.Monad.void $ simpleOpArgs BuildPaths $ do
putPaths storeDir ps
putInt $ fromEnum bm
@ -166,7 +171,7 @@ buildDerivation p drv buildMode = do
ensurePath :: StorePath -> MonadStore ()
ensurePath pn = do
storeDir <- getStoreDir
void $ simpleOpArgs EnsurePath $ putPath storeDir pn
Control.Monad.void $ simpleOpArgs EnsurePath $ putPath storeDir pn
-- | Find garbage collector roots.
findRoots :: MonadStore (Map BSL.ByteString StorePath)
@ -177,18 +182,18 @@ findRoots = do
getSocketIncremental
$ getMany
$ (,)
<$> (fromStrict <$> getByteStringLen)
<$> (BSL.fromStrict <$> getByteStringLen)
<*> getPath sd
r <- catRights res
pure $ Data.Map.Strict.fromList r
where
catRights :: [(a, Either String b)] -> MonadStore [(a, b)]
catRights :: [(a, Either InvalidPathError b)] -> MonadStore [(a, b)]
catRights = mapM ex
ex :: (a, Either [Char] b) -> MonadStore (a, b)
ex :: (a, Either InvalidPathError b) -> MonadStore (a, b)
ex (x , Right y) = pure (x, y)
ex (_x, Left e ) = error $ "Unable to decode root: " <> fromString e
ex (_x, Left e ) = error $ "Unable to decode root: " <> show e
isValidPathUncached :: StorePath -> MonadStore Bool
isValidPathUncached p = do
@ -218,24 +223,24 @@ querySubstitutablePaths ps = do
runOpArgs QuerySubstitutablePaths $ putPaths storeDir ps
sockGetPaths
queryPathInfoUncached :: StorePath -> MonadStore StorePathMetadata
queryPathInfoUncached :: StorePath -> MonadStore (Metadata StorePath)
queryPathInfoUncached path = do
storeDir <- getStoreDir
runOpArgs QueryPathInfo $ do
putPath storeDir path
valid <- sockGetBool
unless valid $ error "Path is not valid"
Control.Monad.unless valid $ error "Path is not valid"
deriverPath <- sockGetPathMay
narHashText <- decodeUtf8 <$> sockGetStr
narHashText <- Data.Text.Encoding.decodeUtf8 <$> sockGetStr
let
narHash =
case
decodeDigestWith @SHA256 NixBase32 narHashText
of
Left e -> error $ fromString e
Left e -> error e
Right x -> SomeDigest x
references <- sockGetPaths
@ -252,14 +257,16 @@ queryPathInfoUncached path = do
contentAddressableAddress =
case
System.Nix.Store.Remote.Parsers.parseContentAddressableAddress caString
Data.Attoparsec.ByteString.Char8.parseOnly
System.Nix.StorePath.contentAddressableAddressParser
caString
of
Left e -> error $ fromString e
Left e -> error e
Right x -> Just x
trust = if ultimate then BuiltLocally else BuiltElsewhere
pure $ StorePathMetadata{..}
pure $ Metadata{..}
queryReferrers :: StorePath -> MonadStore (HashSet StorePath)
queryReferrers p = do
@ -288,11 +295,8 @@ queryDerivationOutputNames p = do
queryPathFromHashPart :: StorePathHashPart -> MonadStore StorePath
queryPathFromHashPart storePathHash = do
runOpArgs QueryPathFromHashPart
$ putByteStringLen
$ encodeUtf8
$ encodeWith NixBase32
$ System.Nix.StorePath.unStorePathHashPart
storePathHash
$ putText
$ System.Nix.StorePath.storePathHashPartToText storePathHash
sockGetPath
queryMissing
@ -316,10 +320,10 @@ queryMissing ps = do
pure (willBuild, willSubstitute, unknown, downloadSize', narSize')
optimiseStore :: MonadStore ()
optimiseStore = void $ simpleOp OptimiseStore
optimiseStore = Control.Monad.void $ simpleOp OptimiseStore
syncWithGC :: MonadStore ()
syncWithGC = void $ simpleOp SyncWithGC
syncWithGC = Control.Monad.void $ simpleOp SyncWithGC
-- returns True on errors
verifyStore :: CheckFlag -> RepairFlag -> MonadStore Bool

4
hnix-store-remote/src/System/Nix/Store/Remote/Binary.hs
View File

@ -4,6 +4,8 @@ Maintainer : srk <srk@48.io>
|-}
module System.Nix.Store.Remote.Binary where
import Control.Monad
import Data.ByteString (ByteString)
import Data.Binary.Get
import Data.Binary.Put
import qualified Data.ByteString.Lazy as BSL
@ -45,7 +47,7 @@ getByteStringLen = do
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 $ toStrict st
pure $ BSL.toStrict st
where unpad x = replicateM x getWord8
getByteStrings :: Get [ByteString]

36
hnix-store-remote/src/System/Nix/Store/Remote/Builders.hs
View File

@ -1,36 +0,0 @@
{-# language AllowAmbiguousTypes #-}
{-# language ScopedTypeVariables #-}
{-# language RankNTypes #-}
module System.Nix.Store.Remote.Builders
( buildContentAddressableAddress
)
where
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 as TL
import System.Nix.Hash
-- | Marshall `ContentAddressableAddress` to `Text`
-- in form suitable for remote protocol usage.
buildContentAddressableAddress :: ContentAddressableAddress -> TL.Text
buildContentAddressableAddress =
TL.toLazyText . contentAddressableAddressBuilder
contentAddressableAddressBuilder :: ContentAddressableAddress -> Builder
contentAddressableAddressBuilder (Text digest) =
"text:" <> digestBuilder digest
contentAddressableAddressBuilder (Fixed _narHashMode (SomeDigest (digest :: Digest hashAlgo))) =
"fixed:"
<> TL.fromText (System.Nix.Hash.algoName @hashAlgo)
<> digestBuilder digest
digestBuilder :: Digest a -> Builder
digestBuilder =
TL.fromText . encodeDigestWith NixBase32

10
hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs
View File

@ -8,8 +8,10 @@ module System.Nix.Store.Remote.Logger
where
import Prelude hiding ( Last )
import Control.Monad.Except ( throwError )
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (asks)
import Control.Monad.State.Strict (get)
import Data.Binary.Get
import Network.Socket.ByteString ( recv )
@ -19,6 +21,8 @@ import System.Nix.Store.Remote.Types
import System.Nix.Store.Remote.Util
import qualified Control.Monad
controlParser :: Get Logger
controlParser = do
ctrl <- getInt
@ -70,12 +74,12 @@ processOutput = go decoder
chunk <- liftIO (Just <$> recv soc 8)
go (k chunk)
go (Fail _leftover _consumed msg) = error $ fromString msg
go (Fail _leftover _consumed msg) = error msg
getFields :: Get [Field]
getFields = do
cnt <- getInt
replicateM cnt getField
Control.Monad.replicateM cnt getField
getField :: Get Field
getField = do

51
hnix-store-remote/src/System/Nix/Store/Remote/Parsers.hs
View File

@ -1,51 +0,0 @@
{-# language AllowAmbiguousTypes #-}
{-# language ScopedTypeVariables #-}
{-# language RankNTypes #-}
{-# language DataKinds #-}
module System.Nix.Store.Remote.Parsers
( parseContentAddressableAddress
)
where
import Data.Attoparsec.ByteString.Char8
import System.Nix.Hash
import System.Nix.StorePath ( ContentAddressableAddress(..)
, NarHashMode(..)
)
import Crypto.Hash ( SHA256 )
-- | Parse `ContentAddressableAddress` from `ByteString`
parseContentAddressableAddress
:: ByteString -> Either String ContentAddressableAddress
parseContentAddressableAddress =
Data.Attoparsec.ByteString.Char8.parseOnly contentAddressableAddressParser
-- | Parser for content addressable field
contentAddressableAddressParser :: Parser ContentAddressableAddress
contentAddressableAddressParser = caText <|> caFixed
-- | Parser for @text:sha256:<h>@
caText :: Parser ContentAddressableAddress
caText = do
_ <- "text:sha256:"
digest <- decodeDigestWith @SHA256 NixBase32 <$> parseHash
either fail pure $ Text <$> digest
-- | Parser for @fixed:<r?>:<ht>:<h>@
caFixed :: Parser ContentAddressableAddress
caFixed = do
_ <- "fixed:"
narHashMode <- (Recursive <$ "r:") <|> (RegularFile <$ "")
digest <- parseTypedDigest
either fail pure $ Fixed narHashMode <$> digest
parseTypedDigest :: Parser (Either String SomeNamedDigest)
parseTypedDigest = mkNamedDigest <$> parseHashType <*> parseHash
parseHashType :: Parser Text
parseHashType =
decodeUtf8 <$> ("sha256" <|> "sha512" <|> "sha1" <|> "md5") <* (":" <|> "-")
parseHash :: Parser Text
parseHash = decodeUtf8 <$> takeWhile1 (/= ':')

28
hnix-store-remote/src/System/Nix/Store/Remote/Protocol.hs
View File

@ -16,15 +16,19 @@ module System.Nix.Store.Remote.Protocol
)
where
import qualified Relude.Unsafe as Unsafe
import qualified Control.Monad
import Control.Exception ( bracket )
import Control.Monad.Except
import Control.Monad.Reader (asks, runReaderT)
import Control.Monad.State.Strict
import Data.Default.Class (Default(def))
import qualified Data.Bool
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 as S
@ -123,28 +127,28 @@ opNum QueryMissing = 40
simpleOp :: WorkerOp -> MonadStore Bool
simpleOp op = simpleOpArgs op pass
simpleOp op = simpleOpArgs op $ pure ()
simpleOpArgs :: WorkerOp -> Put -> MonadStore Bool
simpleOpArgs op args = do
runOpArgs op args
err <- gotError
bool
Data.Bool.bool
sockGetBool
(do
Error _num msg <- Unsafe.head <$> getError
Error _num msg <- head <$> getError
throwError $ Data.ByteString.Char8.unpack msg
)
err
runOp :: WorkerOp -> MonadStore ()
runOp op = runOpArgs op pass
runOp op = runOpArgs op $ pure ()
runOpArgs :: WorkerOp -> Put -> MonadStore ()
runOpArgs op args =
runOpArgsIO
op
(\encode -> encode $ toStrict $ runPut args)
(\encode -> encode $ Data.ByteString.Lazy.toStrict $ runPut args)
runOpArgsIO
:: WorkerOp
@ -160,12 +164,12 @@ runOpArgsIO op encoder = do
out <- processOutput
modify (\(a, b) -> (a, b <> out))
err <- gotError
when err $ do
Error _num msg <- Unsafe.head <$> getError
Control.Monad.when err $ do
Error _num msg <- head <$> getError
throwError $ Data.ByteString.Char8.unpack msg
runStore :: MonadStore a -> IO (Either String a, [Logger])
runStore = runStoreOpts defaultSockPath $ StoreDir "/nix/store"
runStore = runStoreOpts defaultSockPath def
runStoreOpts
:: FilePath -> StoreDir -> MonadStore a -> IO (Either String a, [Logger])
@ -198,11 +202,11 @@ runStoreOpts' sockFamily sockAddr storeRootDir code =
vermagic <- liftIO $ recv soc 16
let
(magic2, _daemonProtoVersion) =
flip runGet (fromStrict vermagic)
flip runGet (Data.ByteString.Lazy.fromStrict vermagic)
$ (,)
<$> (getInt :: Get Int)
<*> (getInt :: Get Int)
unless (magic2 == workerMagic2) $ error "Worker magic 2 mismatch"
Control.Monad.unless (magic2 == workerMagic2) $ error "Worker magic 2 mismatch"
sockPut $ putInt protoVersion -- clientVersion
sockPut $ putInt (0 :: Int) -- affinity

106
hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs Normal file
View File

@ -0,0 +1,106 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-|
Description : Serialize instances for complex types
Maintainer : srk <srk@48.io>
|-}
module System.Nix.Store.Remote.Serialize where
import Data.Serialize (Serialize(..))
import Data.Serialize.Get (Get)
import Data.Serialize.Put (Putter)
import Data.Text (Text)
import qualified Data.Bool
import qualified Data.Map
import qualified Data.Set
import qualified Data.Text
import qualified Data.Vector
import Nix.Derivation (Derivation(..), DerivationOutput(..))
import System.Nix.Build (BuildMode(..), BuildStatus(..), BuildResult(..))
import System.Nix.StorePath (StoreDir, StorePath)
import System.Nix.Store.Remote.Serialize.Prim
instance Serialize Text where
get = getText
put = putText
instance Serialize BuildMode where
get = getEnum
put = putEnum
instance Serialize BuildStatus where
get = getEnum
put = putEnum
instance Serialize BuildResult where
get = do
status <- get
errorMessage <-
(\em -> Data.Bool.bool (Just em) Nothing (Data.Text.null em))
<$> get
timesBuilt <- getInt
isNonDeterministic <- getBool
startTime <- getTime
stopTime <- getTime
pure $ BuildResult{..}
put BuildResult{..} = do
put status
case errorMessage of
Just err -> putText err
Nothing -> putText mempty
putInt timesBuilt
putBool isNonDeterministic
putTime startTime
putTime stopTime
getDerivation
:: StoreDir
-> Get (Derivation StorePath Text)
getDerivation storeDir = do
outputs <-
Data.Map.fromList
<$> (getMany $ do
outputName <- get
path <- getPathOrFail storeDir
hashAlgo <- get
hash <- get
pure (outputName, DerivationOutput{..})
)
-- Our type is Derivation, but in Nix
-- the type sent over the wire is BasicDerivation
-- which omits inputDrvs
inputDrvs <- pure mempty
inputSrcs <-
Data.Set.fromList
<$> getMany (getPathOrFail storeDir)
platform <- get
builder <- get
args <-
Data.Vector.fromList
<$> getMany get
env <-
Data.Map.fromList
<$> getMany ((,) <$> get <*> get)
pure Derivation{..}
putDerivation :: StoreDir -> Putter (Derivation StorePath Text)
putDerivation storeDir Derivation{..} = do
flip putMany (Data.Map.toList outputs)
$ \(outputName, DerivationOutput{..}) -> do
putText outputName
putPath storeDir path
putText hashAlgo
putText hash
putMany (putPath storeDir) inputSrcs
putText platform
putText builder
putMany putText args
flip putMany (Data.Map.toList env)
$ \(a1, a2) -> putText a1 *> putText a2

188
hnix-store-remote/src/System/Nix/Store/Remote/Serialize/Prim.hs Normal file
View File

@ -0,0 +1,188 @@
{-|
Description : Nix-like serialization primitives
Maintainer : srk <srk@48.io>
|-}
module System.Nix.Store.Remote.Serialize.Prim where
import Data.ByteString (ByteString)
import Data.Fixed (Uni)
import Data.HashSet (HashSet)
import Data.Serialize.Get (Get)
import Data.Serialize.Put (Putter)
import Data.Text (Text)
import Data.Time (NominalDiffTime, UTCTime)
import System.Nix.StorePath (StoreDir, StorePath, InvalidPathError)
import qualified Control.Monad
import qualified Data.HashSet
import qualified Data.Serialize.Get
import qualified Data.Serialize.Put
import qualified Data.ByteString
import qualified Data.Text.Encoding
import qualified Data.Time.Clock.POSIX
import qualified System.Nix.StorePath
-- * Int
-- | Deserialize Nix like integer
getInt :: Get Int
getInt = fromIntegral <$> Data.Serialize.Get.getWord64le
-- | Serialize Nix like integer
putInt :: Putter Int
putInt = Data.Serialize.Put.putWord64le . fromIntegral
-- * Bool
-- | Deserialize @Bool@ from integer
getBool :: Get Bool
getBool = (== 1) <$> (getInt :: Get Int)
-- | Serialize @Bool@ into integer
putBool :: Putter Bool
putBool True = putInt (1 :: Int)
putBool False = putInt (0 :: Int)
-- * Enum
-- | Deserialize @Enum@ to integer
getEnum :: Enum a => Get a
getEnum = toEnum <$> getInt
-- | Serialize @Enum@ to integer
putEnum :: Enum a => Putter a
putEnum = putInt . fromEnum
-- * UTCTime
-- | Deserialize @UTCTime@ from integer
-- Only 1 second precision.
getTime :: Get UTCTime
getTime =
Data.Time.Clock.POSIX.posixSecondsToUTCTime
. seconds
<$> getInt
where
-- fancy (*10^12), from Int to Uni to Pico(seconds)
seconds :: Int -> NominalDiffTime
seconds n = realToFrac (toEnum n :: Uni)
-- | Serialize @UTCTime@ to integer
-- Only 1 second precision.
putTime :: Putter UTCTime
putTime =
putInt
. seconds
. Data.Time.Clock.POSIX.utcTimeToPOSIXSeconds
where
-- fancy (`div`10^12), from Pico to Uni to Int
seconds :: NominalDiffTime -> Int
seconds = (fromEnum :: Uni -> Int) . realToFrac
-- * Combinators
-- | Deserialize a list
getMany :: Get a -> Get [a]
getMany parser = do
count <- getInt
Control.Monad.replicateM count parser
-- | Serialize a list
putMany :: Foldable t => Putter a -> Putter (t a)
putMany printer xs = do
putInt (length xs)
mapM_ printer xs
-- * ByteString
-- | Deserialize length prefixed string
-- into @ByteString@, checking for correct padding
getByteString :: Get ByteString
getByteString = do
len <- getInt
st <- Data.Serialize.Get.getByteString len
Control.Monad.when (len `mod` 8 /= 0) $ do
pads <- unpad $ fromIntegral $ 8 - (len `mod` 8)
Control.Monad.unless
(all (== 0) pads)
$ fail $ "No zeroes" <> show (st, len, pads)
pure st
where unpad x = Control.Monad.replicateM x Data.Serialize.Get.getWord8
-- | Serialize @ByteString@ using length
-- prefixed string packing with padding to 8 bytes
putByteString :: Putter ByteString
putByteString x = do
putInt len
Data.Serialize.Put.putByteString x
Control.Monad.when
(len `mod` 8 /= 0)
$ pad $ 8 - (len `mod` 8)
where
len :: Int
len = fromIntegral $ Data.ByteString.length x
pad count = Control.Monad.replicateM_ count (Data.Serialize.Put.putWord8 0)
-- | Deserialize a list of @ByteString@s
getByteStrings :: Get [ByteString]
getByteStrings = getMany getByteString
-- | Serialize a list of @ByteString@s
putByteStrings :: Foldable t => Putter (t ByteString)
putByteStrings = putMany putByteString
-- * Text
-- | Deserialize @Text@
getText :: Get Text
getText = Data.Text.Encoding.decodeUtf8 <$> getByteString
-- | Serialize @Text@
putText :: Putter Text
putText = putByteString . Data.Text.Encoding.encodeUtf8
-- | Deserialize a list of @Text@s
getTexts :: Get [Text]
getTexts = fmap Data.Text.Encoding.decodeUtf8 <$> getByteStrings
-- | Serialize a list of @Text@s
putTexts :: (Functor f, Foldable f) => Putter (f Text)
putTexts = putByteStrings . fmap Data.Text.Encoding.encodeUtf8
-- * StorePath
-- | Deserialize @StorePath@, checking
-- that @StoreDir@ matches expected value
getPath :: StoreDir -> Get (Either InvalidPathError StorePath)
getPath sd =
System.Nix.StorePath.parsePath sd <$> getByteString
-- | Deserialize @StorePath@, checking
-- that @StoreDir@ matches expected value
getPathOrFail :: StoreDir -> Get StorePath
getPathOrFail sd =
getPath sd
>>= either
(fail . show)
pure
-- | Serialize @StorePath@ with its associated @StoreDir@
putPath :: StoreDir -> Putter StorePath
putPath storeDir =
putByteString
. System.Nix.StorePath.storePathToRawFilePath storeDir
-- | Deserialize a @HashSet@ of @StorePath@s
getPaths :: StoreDir -> Get (HashSet (Either InvalidPathError StorePath))
getPaths sd =
Data.HashSet.fromList
. fmap (System.Nix.StorePath.parsePath sd)
<$> getByteStrings
-- | Serialize a @HashSet@ of @StorePath@s
putPaths :: StoreDir -> Putter (HashSet StorePath)
putPaths storeDir =
putByteStrings
. Data.HashSet.toList
. Data.HashSet.map
(System.Nix.StorePath.storePathToRawFilePath storeDir)

14
hnix-store-remote/src/System/Nix/Store/Remote/Types.hs
View File

@ -33,13 +33,21 @@ module System.Nix.Store.Remote.Types
)
where
import Control.Monad.Trans.State.Strict (mapStateT)
import Control.Monad.Trans.Except (mapExceptT)
import qualified Data.ByteString.Lazy as BSL
import Control.Monad.Except (ExceptT)
import Control.Monad.Reader (ReaderT, asks)
import Control.Monad.State.Strict (StateT, gets, modify)
import Data.ByteString (ByteString)
import Network.Socket (Socket)
import qualified Data.ByteString.Lazy as BSL
import Control.Monad.Trans.State.Strict (mapStateT)
import Control.Monad.Trans.Except (mapExceptT)
import Control.Monad.Trans.Reader (withReaderT)
import System.Nix.StorePath ( StoreDir )
data StoreConfig = StoreConfig
{ storeDir :: StoreDir
, storeSocket :: Socket

31
hnix-store-remote/src/System/Nix/Store/Remote/Util.hs
View File

@ -1,11 +1,18 @@
{-# language RecordWildCards #-}
module System.Nix.Store.Remote.Util where
import Prelude hiding ( putText )
import Control.Monad.Except
import Control.Monad.Except (throwError)
import Control.Monad.Reader (asks)
import Control.Monad.IO.Class (MonadIO(..))
import Data.ByteString (ByteString)
import Data.HashSet (HashSet)
import Data.Text (Text)
import Data.Either (rights)
import Data.Binary.Get
import Data.Binary.Put
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
@ -34,7 +41,7 @@ genericIncremental getsome parser = go decoder
go (Partial k ) = do
chunk <- getsome
go (k chunk)
go (Fail _leftover _consumed msg) = error $ fromString msg
go (Fail _leftover _consumed msg) = error msg
getSocketIncremental :: Get a -> MonadStore a
getSocketIncremental = genericIncremental sockGet8
@ -47,7 +54,7 @@ getSocketIncremental = genericIncremental sockGet8
sockPut :: Put -> MonadStore ()
sockPut p = do
soc <- asks storeSocket
liftIO $ sendAll soc $ toStrict $ runPut p
liftIO $ sendAll soc $ BSL.toStrict $ runPut p
sockGet :: Get a -> MonadStore a
sockGet = getSocketIncremental
@ -69,7 +76,7 @@ sockGetPath = do
sd <- getStoreDir
pth <- getSocketIncremental (getPath sd)
either
throwError
(throwError . show)
pure
pth
@ -89,16 +96,16 @@ sockGetPaths = do
getSocketIncremental (getPaths sd)
bsToText :: ByteString -> Text
bsToText = decodeUtf8
bsToText = T.decodeUtf8
textToBS :: Text -> ByteString
textToBS = encodeUtf8
textToBS = T.encodeUtf8
bslToText :: BSL.ByteString -> Text
bslToText = toText . TL.decodeUtf8
bslToText = TL.toStrict . TL.decodeUtf8
textToBSL :: Text -> BSL.ByteString
textToBSL = TL.encodeUtf8 . toLText
textToBSL = TL.encodeUtf8 . TL.fromStrict
putText :: Text -> Put
putText = putByteStringLen . textToBSL
@ -106,7 +113,7 @@ putText = putByteStringLen . textToBSL
putTexts :: [Text] -> Put
putTexts = putByteStrings . fmap textToBSL
getPath :: StoreDir -> Get (Either String StorePath)
getPath :: StoreDir -> Get (Either InvalidPathError StorePath)
getPath sd = parsePath sd <$> getByteStringLen
getPaths :: StoreDir -> Get (HashSet StorePath)
@ -114,11 +121,11 @@ getPaths sd =
Data.HashSet.fromList . rights . fmap (parsePath sd) <$> getByteStrings
putPath :: StoreDir -> StorePath -> Put
putPath storeDir = putByteStringLen . fromStrict . storePathToRawFilePath storeDir
putPath storeDir = putByteStringLen . BSL.fromStrict . storePathToRawFilePath storeDir
putPaths :: StoreDir -> HashSet StorePath -> Put
putPaths storeDir = putByteStrings . Data.HashSet.toList . Data.HashSet.map
(fromStrict . storePathToRawFilePath storeDir)
(BSL.fromStrict . storePathToRawFilePath storeDir)
putBool :: Bool -> Put
putBool True = putInt (1 :: Int)

34
hnix-store-remote/tests-io/NixDaemon.hs
View File

@ -1,9 +1,17 @@
{-# language DataKinds #-}
{-# language ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
module NixDaemon where
import qualified System.Environment as Env
import Data.Text (Text)
import Data.Either ( isRight
, isLeft
)
import Data.Bool ( bool )
import Control.Monad ( void )
import Control.Monad.IO.Class ( liftIO )
import qualified System.Environment
import Control.Exception ( bracket )
import Control.Concurrent ( threadDelay )
import qualified Data.ByteString.Char8 as BSC
@ -34,7 +42,7 @@ import System.Nix.Nar ( dumpPath )
createProcessEnv :: FilePath -> String -> [String] -> IO P.ProcessHandle
createProcessEnv fp proc args = do
mPath <- Env.lookupEnv "PATH"
mPath <- System.Environment.lookupEnv "PATH"
(_, _, _, ph) <-
P.createProcess (P.proc proc args)
@ -44,13 +52,13 @@ createProcessEnv fp proc args = do
pure ph
mockedEnv :: Maybe String -> FilePath -> [(String, FilePath)]
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")
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")
, ("HOME" , fp </> "home")
-- , ("NIX_REMOTE", "daemon")
] <> foldMap (\x -> [("PATH", x)]) mEnvPath
@ -60,12 +68,12 @@ waitSocket fp x = do
ex <- doesFileExist fp
bool
(threadDelay 100000 >> waitSocket fp (x - 1))
pass
(pure ())
ex
writeConf :: FilePath -> IO ()
writeConf fp =
writeFileText fp $ unlines
writeFile fp $ unlines
[ "build-users-group = "
, "trusted-users = root"
, "allowed-users = *"
@ -136,7 +144,7 @@ it
-> (a -> Bool)
-> Hspec.SpecWith (m () -> IO (a, b))
it name action check =
Hspec.it name $ \run -> run (action >> pass) `checks` check
Hspec.it name $ \run -> run (void $ action) `checks` check
itRights
:: (Show a, Show b, Show c, Monad m)

1
hnix-store-remote/tests/Driver.hs Normal file
View File

@ -0,0 +1 @@
{-# OPTIONS_GHC -F -pgmF tasty-discover #-}

159
hnix-store-remote/tests/SerializeSpec.hs Normal file
View File

@ -0,0 +1,159 @@
{-# LANGUAGE NumericUnderscores #-}
module SerializeSpec where
import Data.ByteString (ByteString)
import Data.Fixed (Uni)
import Data.HashSet (HashSet)
import Data.Serialize (Serialize(..))
import Data.Serialize.Get (Get, runGet)
import Data.Serialize.Put (Putter, runPut)
import Data.Text (Text)
import Data.Time (NominalDiffTime)
import Test.Hspec (Spec, describe, it, shouldBe)
import Test.Tasty.QuickCheck
import Test.QuickCheck.Instances ()
import qualified Data.Either
import qualified Data.HashSet
import qualified Data.Time.Clock.POSIX
import qualified System.Nix.Build
import Nix.Derivation (Derivation(..))
import System.Nix.Build (BuildMode, BuildStatus)
import System.Nix.Derivation ()
import System.Nix.StorePath (StoreDir, StorePath)
import System.Nix.Store.Remote.Serialize (getDerivation, putDerivation)
import System.Nix.Store.Remote.Serialize.Prim
roundTrip :: (Eq a, Show a) => Putter a -> Get a -> a -> Property
roundTrip p g a = res === Right a
where res = runGet g (runPut (p a))
-- * Prim
-- ** Int
prop_int :: Int -> Property
prop_int = roundTrip putInt getInt
-- ** Bool
prop_bool :: Bool -> Property
prop_bool = roundTrip putBool getBool
-- ** UTCTime
prop_time :: Int -> Property
prop_time =
roundTrip
(putTime . Data.Time.Clock.POSIX.posixSecondsToUTCTime . toSeconds)
(fromSeconds . Data.Time.Clock.POSIX.utcTimeToPOSIXSeconds <$> getTime)
where
-- scale to seconds and back
toSeconds :: Int -> NominalDiffTime
toSeconds n = realToFrac (toEnum n :: Uni)
fromSeconds :: NominalDiffTime -> Int
fromSeconds = (fromEnum :: Uni -> Int) . realToFrac
-- ** Combinators
prop_many :: [Int] -> Property
prop_many = roundTrip (putMany putInt) (getMany getInt)
-- ** ByteString
prop_bytestring :: ByteString -> Property
prop_bytestring = roundTrip putByteString getByteString
prop_bytestrings :: [ByteString] -> Property
prop_bytestrings = roundTrip putByteStrings getByteStrings
-- ** Text
prop_text :: Text -> Property
prop_text = roundTrip putText getText
prop_texts :: [Text] -> Property
prop_texts = roundTrip putTexts getTexts
-- ** StorePath
prop_path :: StoreDir -> StorePath -> Property
prop_path = \sd ->
roundTrip
(putPath sd)
(Data.Either.fromRight undefined <$> getPath sd)
prop_paths :: StoreDir -> HashSet StorePath -> Property
prop_paths = \sd ->
roundTrip
(putPaths sd)
(Data.HashSet.map (Data.Either.fromRight undefined) <$> getPaths sd)
-- * Serialize
roundTripS :: (Eq a, Serialize a, Show a) => a -> Property
roundTripS a = res === Right a
where res = runGet get (runPut (put a))
-- ** Text
prop_Text :: Text -> Property
prop_Text = roundTripS
-- ** BuildMode
prop_buildMode :: BuildMode -> Property
prop_buildMode = roundTripS
-- ** BuildStatus
prop_buildStatus :: BuildStatus -> Property
prop_buildStatus = roundTripS
-- ** BuildResult
prop_buildResult :: Property
prop_buildResult =
forAll (arbitrary `suchThat` ((/= Just "") . System.Nix.Build.errorMessage))
$ \br ->
roundTripS
$ br { System.Nix.Build.startTime = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0
, System.Nix.Build.stopTime = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0
}
-- ** Enums
spec_buildEnums :: Spec
spec_buildEnums =
let it' name constr value = it name $ runPut (put constr) `shouldBe` runPut (putInt value)
in do
describe "Build enum order matches Nix" $ do
it' "Normal" System.Nix.Build.Normal 0
it' "Repair" System.Nix.Build.Repair 1
it' "Check" System.Nix.Build.Check 2
describe "BuildStatus enum order matches Nix" $ do
it' "Built" System.Nix.Build.Built 0
it' "Substituted" System.Nix.Build.Substituted 1
it' "AlreadyValid" System.Nix.Build.AlreadyValid 2
it' "PermanentFailure" System.Nix.Build.PermanentFailure 3
it' "InputRejected" System.Nix.Build.InputRejected 4
it' "OutputRejected" System.Nix.Build.OutputRejected 5
it' "TransientFailure" System.Nix.Build.TransientFailure 6
it' "CachedFailure" System.Nix.Build.CachedFailure 7
it' "TimedOut" System.Nix.Build.TimedOut 8
it' "MiscFailure" System.Nix.Build.MiscFailure 9
it' "DependencyFailed" System.Nix.Build.DependencyFailed 10
it' "LogLimitExceeded" System.Nix.Build.LogLimitExceeded 11
it' "NotDeterministic" System.Nix.Build.NotDeterministic 12
it' "ResolvesToAlreadyValid" System.Nix.Build.ResolvesToAlreadyValid 13
it' "NoSubstituters" System.Nix.Build.NoSubstituters 14
-- ** Derivation
prop_derivation :: StoreDir -> Derivation StorePath Text -> Property
prop_derivation sd drv =
roundTrip
(putDerivation sd)
(getDerivation sd)
-- inputDrvs is not used in remote protocol serialization
(drv { inputDrvs = mempty })