mirror of
https://github.com/haskell-nix/hnix-store.git
synced 2024-11-30 12:53:11 +03:00
Core, Remote: handcrafted code clean-up (#134)
`brittany` was used. Then all changes passed through manual supervision. Then handcrafted code cleanup was done. All changes are pure lambda code refactoring, there should be no changes to the functionality.
This commit is contained in:
Anton Latukha
GitHub
parent
ff200aa3e3
commit
792c76b0af
@ -1,2 +1,2 @@
|
||||
import Distribution.Simple
|
||||
import Distribution.Simple
|
||||
main = defaultMain
|
||||
|
||||
@ -1,9 +1,10 @@
|
||||
{-|
|
||||
Description: Implementation of Nix's base32 encoding.
|
||||
-}
|
||||
module System.Nix.Base32 (
|
||||
encode
|
||||
module System.Nix.Base32
|
||||
( encode
|
||||
, decode
|
||||
) where
|
||||
)
|
||||
where
|
||||
|
||||
import System.Nix.Internal.Base32
|
||||
import System.Nix.Internal.Base32
|
||||
|
||||
@ -3,15 +3,16 @@
|
||||
Description : Build related types
|
||||
Maintainer : srk <srk@48.io>
|
||||
|-}
|
||||
module System.Nix.Build (
|
||||
BuildMode(..)
|
||||
module System.Nix.Build
|
||||
( BuildMode(..)
|
||||
, BuildStatus(..)
|
||||
, BuildResult(..)
|
||||
, buildSuccess
|
||||
) where
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Time (UTCTime)
|
||||
import Data.Text (Text)
|
||||
import Data.Time ( UTCTime )
|
||||
import Data.Text ( Text )
|
||||
|
||||
-- keep the order of these Enums to match enums from reference implementations
|
||||
-- src/libstore/store-api.hh
|
||||
@ -49,12 +50,9 @@ data BuildResult = BuildResult
|
||||
startTime :: !UTCTime
|
||||
, -- Stop time of this build
|
||||
stopTime :: !UTCTime
|
||||
} deriving (Eq, Ord, Show)
|
||||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
buildSuccess :: BuildResult -> Bool
|
||||
buildSuccess BuildResult{..} =
|
||||
status `elem`
|
||||
[ Built
|
||||
, Substituted
|
||||
, AlreadyValid
|
||||
]
|
||||
buildSuccess BuildResult {..} =
|
||||
status `elem` [Built, Substituted, AlreadyValid]
|
||||
|
||||
@ -1,19 +1,22 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module System.Nix.Derivation (
|
||||
parseDerivation
|
||||
module System.Nix.Derivation
|
||||
( parseDerivation
|
||||
, buildDerivation
|
||||
) where
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Lazy.Builder as Text.Lazy (Builder)
|
||||
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 (StorePath)
|
||||
import qualified System.Nix.StorePath as StorePath
|
||||
import Data.Text ( Text )
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Lazy.Builder as Text.Lazy
|
||||
( Builder )
|
||||
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 ( StorePath )
|
||||
import qualified System.Nix.StorePath as StorePath
|
||||
|
||||
|
||||
|
||||
|
||||
@ -1,8 +1,8 @@
|
||||
{-|
|
||||
Description : Cryptographic hashes for hnix-store.
|
||||
-}
|
||||
module System.Nix.Hash (
|
||||
Hash.Digest
|
||||
module System.Nix.Hash
|
||||
( Hash.Digest
|
||||
|
||||
, Hash.HashAlgorithm(..)
|
||||
, Hash.ValidAlgo(..)
|
||||
@ -16,6 +16,7 @@ module System.Nix.Hash (
|
||||
, Hash.BaseEncoding(..)
|
||||
, Hash.encodeInBase
|
||||
, Hash.decodeBase
|
||||
) where
|
||||
)
|
||||
where
|
||||
|
||||
import qualified System.Nix.Internal.Hash as Hash
|
||||
import qualified System.Nix.Internal.Hash as Hash
|
||||
|
||||
@ -1,18 +1,19 @@
|
||||
module System.Nix.Internal.Base32 where
|
||||
|
||||
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as Bytes
|
||||
import qualified Data.ByteString.Char8 as Bytes.Char8
|
||||
import Data.Bool ( bool )
|
||||
import Data.Maybe ( fromMaybe )
|
||||
import Data.ByteString ( ByteString )
|
||||
import qualified Data.ByteString as Bytes
|
||||
import qualified Data.ByteString.Char8 as Bytes.Char8
|
||||
import qualified Data.Text
|
||||
import Data.Vector (Vector)
|
||||
import qualified Data.Vector as Vector
|
||||
import Data.Text (Text)
|
||||
import Data.Bits (shiftR)
|
||||
import Data.Word (Word8)
|
||||
import Data.List (unfoldr)
|
||||
import Numeric (readInt)
|
||||
import Data.Vector ( Vector )
|
||||
import qualified Data.Vector as Vector
|
||||
import Data.Text ( Text )
|
||||
import Data.Bits ( shiftR )
|
||||
import Data.Word ( Word8 )
|
||||
import Data.List ( unfoldr )
|
||||
import Numeric ( readInt )
|
||||
|
||||
|
||||
-- omitted: E O U T
|
||||
@ -32,7 +33,7 @@ encode c = Data.Text.pack $ map char32 [nChar - 1, nChar - 2 .. 0]
|
||||
-- the - 1 inside of it.
|
||||
nChar = fromIntegral $ ((Bytes.length c * 8 - 1) `div` 5) + 1
|
||||
|
||||
byte = Bytes.index c . fromIntegral
|
||||
byte = Bytes.index c . fromIntegral
|
||||
|
||||
-- May need to switch to a more efficient calculation at some
|
||||
-- point.
|
||||
@ -52,30 +53,34 @@ encode c = Data.Text.pack $ map char32 [nChar - 1, nChar - 2 .. 0]
|
||||
-- | Decode Nix's base32 encoded text
|
||||
decode :: Text -> Either String ByteString
|
||||
decode what =
|
||||
if Data.Text.all (`elem` digits32) what
|
||||
then unsafeDecode what
|
||||
else Left "Invalid base32 string"
|
||||
bool
|
||||
(Left "Invalid Base32 string")
|
||||
(unsafeDecode what)
|
||||
(Data.Text.all (`elem` digits32) what)
|
||||
|
||||
-- | Decode Nix's base32 encoded text
|
||||
-- Doesn't check if all elements match `digits32`
|
||||
unsafeDecode :: Text -> Either String ByteString
|
||||
unsafeDecode what =
|
||||
case readInt 32
|
||||
(`elem` digits32)
|
||||
(\c -> fromMaybe (error "character not in digits32")
|
||||
$ Vector.findIndex (==c) digits32)
|
||||
(Data.Text.unpack what)
|
||||
case
|
||||
readInt
|
||||
32
|
||||
(`elem` digits32)
|
||||
(\c -> fromMaybe (error "character not in digits32")
|
||||
$ Vector.findIndex (== c) digits32
|
||||
)
|
||||
(Data.Text.unpack what)
|
||||
of
|
||||
[(i, _)] -> Right $ padded $ integerToBS i
|
||||
x -> Left $ "Can't decode: readInt returned " ++ show x
|
||||
where
|
||||
padded x
|
||||
| Bytes.length x < decLen = x `Bytes.append` bstr
|
||||
| otherwise = x
|
||||
where
|
||||
bstr = Bytes.Char8.pack $ take (decLen - Bytes.length x) (cycle "\NUL")
|
||||
where
|
||||
padded x
|
||||
| Bytes.length x < decLen = x `Bytes.append` bstr
|
||||
| otherwise = x
|
||||
where
|
||||
bstr = Bytes.Char8.pack $ take (decLen - Bytes.length x) (cycle "\NUL")
|
||||
|
||||
decLen = Data.Text.length what * 5 `div` 8
|
||||
decLen = Data.Text.length what * 5 `div` 8
|
||||
|
||||
-- | Encode an Integer to a bytestring
|
||||
-- Similar to Data.Base32String (integerToBS) without `reverse`
|
||||
|
||||
@ -13,7 +13,10 @@ import qualified Algebra.Graph as Graph
|
||||
import qualified Algebra.Graph.ToGraph as Graph
|
||||
import qualified Control.Concurrent as Concurrent
|
||||
import qualified Control.Exception.Lifted as Exception.Lifted
|
||||
import Control.Monad (forM, when, forM_)
|
||||
import Control.Monad ( forM
|
||||
, when
|
||||
, forM_
|
||||
)
|
||||
import qualified Control.Monad.Except as Except
|
||||
import qualified Control.Monad.Fail as Fail
|
||||
import qualified Control.Monad.IO.Class as IO
|
||||
@ -21,16 +24,17 @@ import qualified Control.Monad.Reader as Reader
|
||||
import qualified Control.Monad.State as State
|
||||
import qualified Control.Monad.Trans as Trans
|
||||
import qualified Control.Monad.Trans.Control as Base
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.ByteString ( ByteString )
|
||||
import qualified Data.ByteString as Bytes
|
||||
import Data.Bool ( bool )
|
||||
import qualified Data.Either as Either
|
||||
import Data.Int (Int64)
|
||||
import Data.Int ( Int64 )
|
||||
import qualified Data.IORef as IORef
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Maybe ( catMaybes )
|
||||
import qualified Data.Serialize as Serialize
|
||||
import Data.Text (Text)
|
||||
import Data.Text ( Text )
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as Text
|
||||
import qualified System.Directory as Directory
|
||||
@ -68,7 +72,8 @@ newtype NarParser m a = NarParser
|
||||
-- This is suitable for testing the top-level NAR parser, or any of the
|
||||
-- smaller utilities parsers, if you have bytes appropriate for them
|
||||
runParser
|
||||
:: forall m a.(IO.MonadIO m, Base.MonadBaseControl IO m)
|
||||
:: forall m a
|
||||
. (IO.MonadIO m, Base.MonadBaseControl IO m)
|
||||
=> Nar.NarEffects m
|
||||
-- ^ Provide the effects set, usually @narEffectsIO@
|
||||
-> NarParser m a
|
||||
@ -80,9 +85,9 @@ runParser
|
||||
-- ^ The root file system object to be created by the NAR
|
||||
-> m (Either String a)
|
||||
runParser effs (NarParser action) h target = do
|
||||
unpackResult <- Reader.runReaderT
|
||||
(Except.runExceptT $ State.evalStateT action state0) effs
|
||||
`Exception.Lifted.catch` exceptionHandler
|
||||
unpackResult <-
|
||||
Reader.runReaderT (Except.runExceptT $ State.evalStateT action state0) effs
|
||||
`Exception.Lifted.catch` exceptionHandler
|
||||
when (Either.isLeft unpackResult) cleanup
|
||||
return unpackResult
|
||||
|
||||
@ -97,15 +102,17 @@ runParser effs (NarParser action) h target = do
|
||||
}
|
||||
|
||||
exceptionHandler :: Exception.Lifted.SomeException -> m (Either String a)
|
||||
exceptionHandler e = return $ Left $ "Exception while unpacking NAR file: " <> show e
|
||||
exceptionHandler e =
|
||||
return $ Left $ "Exception while unpacking NAR file: " <> show e
|
||||
|
||||
cleanup :: m ()
|
||||
cleanup =
|
||||
( \ ef trg -> do
|
||||
(\ef trg -> do
|
||||
isDir <- Nar.narIsDir ef trg
|
||||
if isDir
|
||||
then Nar.narDeleteDir ef trg
|
||||
else Nar.narDeleteFile ef trg
|
||||
bool
|
||||
(Nar.narDeleteFile ef trg)
|
||||
(Nar.narDeleteDir ef trg)
|
||||
isDir
|
||||
) effs target
|
||||
|
||||
|
||||
@ -146,9 +153,9 @@ parseFSO :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m ()
|
||||
parseFSO = do
|
||||
expectStr "type"
|
||||
matchStr
|
||||
[("symlink", parseSymlink)
|
||||
,("regular", parseFile)
|
||||
,("directory", parseDirectory)
|
||||
[ ("symlink" , parseSymlink )
|
||||
, ("regular" , parseFile )
|
||||
, ("directory", parseDirectory)
|
||||
]
|
||||
|
||||
|
||||
@ -160,19 +167,19 @@ parseFSO = do
|
||||
parseSymlink :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m ()
|
||||
parseSymlink = do
|
||||
expectStr "target"
|
||||
target <- parseStr
|
||||
(dir,file) <- currentDirectoryAndFile
|
||||
pushLink $ LinkInfo
|
||||
{ linkTarget = Text.unpack target
|
||||
, linkFile = file
|
||||
, linkPWD = dir
|
||||
}
|
||||
target <- parseStr
|
||||
(dir, file) <- currentDirectoryAndFile
|
||||
pushLink $
|
||||
LinkInfo
|
||||
{ linkTarget = Text.unpack target
|
||||
, linkFile = file
|
||||
, linkPWD = dir
|
||||
}
|
||||
where
|
||||
currentDirectoryAndFile :: Monad m => NarParser m (FilePath, FilePath)
|
||||
currentDirectoryAndFile = do
|
||||
dirStack <- State.gets directoryStack
|
||||
return ( List.foldr1 (</>) (List.reverse $ drop 1 dirStack)
|
||||
, head dirStack)
|
||||
return (List.foldr1 (</>) (List.reverse $ drop 1 dirStack), head dirStack)
|
||||
|
||||
|
||||
-- | Internal data type representing symlinks encountered in the NAR
|
||||
@ -183,25 +190,27 @@ data LinkInfo = LinkInfo
|
||||
-- ^ file name of the link being created
|
||||
, linkPWD :: String
|
||||
-- ^ directory in which to create the link (relative to unpacking root)
|
||||
} deriving (Show)
|
||||
}
|
||||
deriving Show
|
||||
|
||||
|
||||
-- | When the NAR includes a file, we read from the NAR handle in chunks and
|
||||
-- write the target in chunks. This lets us avoid reading the full contents
|
||||
-- of the encoded file into memory
|
||||
parseFile :: forall m.(IO.MonadIO m, Fail.MonadFail m) => NarParser m ()
|
||||
parseFile :: forall m . (IO.MonadIO m, Fail.MonadFail m) => NarParser m ()
|
||||
parseFile = do
|
||||
|
||||
s <- parseStr
|
||||
when (s `notElem` ["executable", "contents"])
|
||||
$ Fail.fail $
|
||||
"Parser found " <> show s <> " when expecting element from "
|
||||
<> (show :: [String] -> String) ["executable", "contents"]
|
||||
when (s `notElem` ["executable", "contents"]) $
|
||||
Fail.fail
|
||||
$ "Parser found " <> show s
|
||||
<> " when expecting element from "
|
||||
<> (show :: [String] -> String) ["executable", "contents"]
|
||||
when (s == "executable") $ do
|
||||
expectStr ""
|
||||
expectStr "contents"
|
||||
|
||||
fSize <- parseLength
|
||||
fSize <- parseLength
|
||||
|
||||
-- Set up for defining `getChunk`
|
||||
narHandle <- State.gets handle
|
||||
@ -245,21 +254,21 @@ parseFile = do
|
||||
parseDirectory :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m ()
|
||||
parseDirectory = do
|
||||
createDirectory <- Reader.asks Nar.narCreateDir
|
||||
target <- currentFile
|
||||
target <- currentFile
|
||||
Trans.lift $ createDirectory target
|
||||
parseEntryOrFinish
|
||||
|
||||
where
|
||||
|
||||
parseEntryOrFinish :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m ()
|
||||
parseEntryOrFinish = do
|
||||
parseEntryOrFinish =
|
||||
-- If we reach a ")", we finished the directory's entries, and we have
|
||||
-- to put ")" back into the stream, because the outer call to @parens@
|
||||
-- expects to consume it.
|
||||
-- Otherwise, parse an entry as a fresh file system object
|
||||
matchStr
|
||||
[ (")", pushStr ")")
|
||||
, ("entry", parseEntry )
|
||||
[ ( ")" , pushStr ")" )
|
||||
, ("entry", parseEntry )
|
||||
]
|
||||
|
||||
parseEntry :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m ()
|
||||
@ -286,13 +295,13 @@ parseStr :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m Text
|
||||
parseStr = do
|
||||
cachedStr <- popStr
|
||||
case cachedStr of
|
||||
Just str -> do
|
||||
return str
|
||||
Just str -> pure str
|
||||
Nothing -> do
|
||||
len <- parseLength
|
||||
len <- parseLength
|
||||
strBytes <- consume $ fromIntegral len
|
||||
expectRawString (Bytes.replicate (fromIntegral $ padLen $ fromIntegral len) 0)
|
||||
return $ Text.decodeUtf8 strBytes
|
||||
expectRawString
|
||||
(Bytes.replicate (fromIntegral $ padLen $ fromIntegral len) 0)
|
||||
pure $ Text.decodeUtf8 strBytes
|
||||
|
||||
|
||||
-- | Get an Int64 describing the length of the upcoming string,
|
||||
@ -300,38 +309,46 @@ parseStr = do
|
||||
parseLength :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m Int64
|
||||
parseLength = do
|
||||
eightBytes <- consume 8
|
||||
case Serialize.runGet Serialize.getInt64le eightBytes of
|
||||
Left e -> Fail.fail $ "parseLength failed to decode int64: " <> e
|
||||
Right n -> return n
|
||||
either
|
||||
(\e -> Fail.fail $ "parseLength failed to decode int64: " <> e)
|
||||
pure
|
||||
(Serialize.runGet Serialize.getInt64le eightBytes)
|
||||
|
||||
|
||||
-- | Consume a NAR string and assert that it matches an expectation
|
||||
expectStr :: (IO.MonadIO m, Fail.MonadFail m) => Text -> NarParser m ()
|
||||
expectStr expected = do
|
||||
actual <- parseStr
|
||||
when (actual /= expected)
|
||||
(Fail.fail $ "Expected " <> err expected <> ", got " <> err actual )
|
||||
when (actual /= expected) $
|
||||
Fail.fail $ "Expected " <> err expected <> ", got " <> err actual
|
||||
where
|
||||
err t =
|
||||
show $
|
||||
if Text.length t > 10
|
||||
then Text.take 10 t
|
||||
else t
|
||||
bool
|
||||
t
|
||||
(Text.take 10 t <> "...")
|
||||
(Text.length t > 10)
|
||||
|
||||
|
||||
-- | Consume a raw string and assert that it equals some expectation.
|
||||
-- This is usually used when consuming padding 0's
|
||||
expectRawString :: (IO.MonadIO m, Fail.MonadFail m) => ByteString -> NarParser m ()
|
||||
expectRawString
|
||||
:: (IO.MonadIO m, Fail.MonadFail m) => ByteString -> NarParser m ()
|
||||
expectRawString expected = do
|
||||
actual <- consume $ Bytes.length expected
|
||||
when (actual /= expected) $
|
||||
Fail.fail $ "Expected " <> err expected <> ", got " <> err actual
|
||||
when (actual /= expected)
|
||||
$ Fail.fail
|
||||
$ "Expected "
|
||||
<> err expected
|
||||
<> ", got "
|
||||
<> err actual
|
||||
where
|
||||
err bs =
|
||||
show $
|
||||
if Bytes.length bs > 10
|
||||
then Bytes.take 10 bs <> "..."
|
||||
else bs
|
||||
bool
|
||||
bs
|
||||
(Bytes.take 10 bs <> "...")
|
||||
(Bytes.length bs > 10)
|
||||
|
||||
|
||||
-- | Consume a NAR string, and dispatch to a parser depending on which string
|
||||
@ -344,8 +361,9 @@ matchStr
|
||||
matchStr parsers = do
|
||||
str <- parseStr
|
||||
case List.lookup str parsers of
|
||||
Just p -> p
|
||||
Nothing -> Fail.fail $ "Expected one of " <> show (fst <$> parsers) <> " found " <> show str
|
||||
Just p -> p
|
||||
Nothing ->
|
||||
Fail.fail $ "Expected one of " <> show (fst <$> parsers) <> " found " <> show str
|
||||
|
||||
|
||||
-- | Wrap any parser in NAR formatted parentheses
|
||||
@ -410,7 +428,7 @@ consume
|
||||
-> NarParser m ByteString
|
||||
consume 0 = return ""
|
||||
consume n = do
|
||||
state0 <- State.get
|
||||
state0 <- State.get
|
||||
newBytes <- IO.liftIO $ Bytes.hGetSome (handle state0) (max 0 n)
|
||||
when (Bytes.length newBytes < n) $
|
||||
Fail.fail $
|
||||
@ -424,8 +442,8 @@ popStr :: Monad m => NarParser m (Maybe Text)
|
||||
popStr = do
|
||||
s <- State.get
|
||||
case List.uncons (tokenStack s) of
|
||||
Nothing -> return Nothing
|
||||
Just (x,xs) -> do
|
||||
Nothing -> return Nothing
|
||||
Just (x, xs) -> do
|
||||
State.put $ s { tokenStack = xs }
|
||||
return $ Just x
|
||||
|
||||
@ -439,7 +457,8 @@ pushStr str =
|
||||
|
||||
-- | Push a level onto the directory stack
|
||||
pushFileName :: Monad m => FilePath -> NarParser m ()
|
||||
pushFileName fName = State.modify (\s -> s { directoryStack = fName : directoryStack s })
|
||||
pushFileName fName =
|
||||
State.modify (\s -> s { directoryStack = fName : directoryStack s })
|
||||
|
||||
|
||||
-- | Go to the parent level in the directory stack
|
||||
@ -473,13 +492,14 @@ testParser p b = do
|
||||
tmpFileName = "tmp"
|
||||
|
||||
testParser' :: (m ~ IO) => FilePath -> IO (Either String ())
|
||||
testParser' fp = IO.withFile fp IO.ReadMode $ \h -> runParser Nar.narEffectsIO parseNar h "tmp"
|
||||
testParser' fp =
|
||||
IO.withFile fp IO.ReadMode $ \h -> runParser Nar.narEffectsIO parseNar h "tmp"
|
||||
|
||||
|
||||
|
||||
|
||||
-- | Distance to the next multiple of 8
|
||||
padLen:: Int -> Int
|
||||
padLen :: Int -> Int
|
||||
padLen n = (8 - n) `mod` 8
|
||||
|
||||
|
||||
|
||||
@ -1,24 +1,24 @@
|
||||
-- | Stream out a NAR file from a regular file
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module System.Nix.Internal.Nar.Streamer where
|
||||
|
||||
import Control.Monad (forM_, when)
|
||||
import Control.Monad ( forM_
|
||||
, when
|
||||
)
|
||||
import qualified Control.Monad.IO.Class as IO
|
||||
import Data.Bool (bool)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Bool ( bool )
|
||||
import Data.ByteString ( ByteString )
|
||||
import qualified Data.ByteString as Bytes
|
||||
import qualified Data.ByteString.Char8 as Bytes.Char8
|
||||
import qualified Data.ByteString.Lazy as Bytes.Lazy
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Serialize as Serial
|
||||
import GHC.Int (Int64)
|
||||
import GHC.Int ( Int64 )
|
||||
import qualified System.Directory as Directory
|
||||
import System.FilePath ((</>))
|
||||
import System.FilePath ( (</>) )
|
||||
|
||||
import qualified System.Nix.Internal.Nar.Effects as Nar
|
||||
|
||||
@ -27,7 +27,8 @@ import qualified System.Nix.Internal.Nar.Effects as Nar
|
||||
-- function from any streaming library, and repeatedly calls
|
||||
-- it while traversing the filesystem object to Nar encode
|
||||
streamNarIO
|
||||
:: forall m.(IO.MonadIO m)
|
||||
:: forall m
|
||||
. (IO.MonadIO m)
|
||||
=> (ByteString -> m ())
|
||||
-> Nar.NarEffects IO
|
||||
-> FilePath
|
||||
@ -51,7 +52,7 @@ streamNarIO yield effs basePath = do
|
||||
|
||||
when isRegular $ do
|
||||
isExec <- IO.liftIO $ isExecutable effs path
|
||||
yield $ strs ["type","regular"]
|
||||
yield $ strs ["type", "regular"]
|
||||
when (isExec == Executable) $ yield $ strs ["executable", ""]
|
||||
fSize <- IO.liftIO $ Nar.narFileSize effs path
|
||||
yield $ str "contents"
|
||||
@ -69,8 +70,11 @@ streamNarIO yield effs basePath = do
|
||||
parens $ go fullName
|
||||
|
||||
str :: ByteString -> ByteString
|
||||
str t = let len = Bytes.length t
|
||||
in int len <> padBS len t
|
||||
str t =
|
||||
let
|
||||
len = Bytes.length t
|
||||
in
|
||||
int len <> padBS len t
|
||||
|
||||
padBS :: Int -> ByteString -> ByteString
|
||||
padBS strSize bs = bs <> Bytes.replicate (padLen strSize) 0
|
||||
@ -95,12 +99,15 @@ streamNarIO yield effs basePath = do
|
||||
|
||||
|
||||
data IsExecutable = NonExecutable | Executable
|
||||
deriving (Eq, Show)
|
||||
deriving (Eq, Show)
|
||||
|
||||
isExecutable :: Functor m => Nar.NarEffects m -> FilePath -> m IsExecutable
|
||||
isExecutable effs fp =
|
||||
bool NonExecutable Executable . Directory.executable <$> Nar.narGetPerms effs fp
|
||||
bool
|
||||
NonExecutable
|
||||
Executable
|
||||
. Directory.executable <$> Nar.narGetPerms effs fp
|
||||
|
||||
-- | Distance to the next multiple of 8
|
||||
padLen:: Int -> Int
|
||||
padLen :: Int -> Int
|
||||
padLen n = (8 - n) `mod` 8
|
||||
|
||||
@ -6,11 +6,11 @@ Description : Nix-relevant interfaces to NaCl signatures.
|
||||
module System.Nix.Internal.Signature where
|
||||
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as Bytes
|
||||
import Data.Coerce (coerce)
|
||||
import Crypto.Saltine.Core.Sign (PublicKey)
|
||||
import Crypto.Saltine.Class (IsEncoding(..))
|
||||
import Data.ByteString ( ByteString )
|
||||
import qualified Data.ByteString as Bytes
|
||||
import Data.Coerce ( coerce )
|
||||
import Crypto.Saltine.Core.Sign ( PublicKey )
|
||||
import Crypto.Saltine.Class ( IsEncoding(..) )
|
||||
import qualified Crypto.Saltine.Internal.ByteSizes as NaClSizes
|
||||
|
||||
|
||||
@ -20,7 +20,7 @@ newtype Signature = Signature ByteString
|
||||
|
||||
instance IsEncoding Signature where
|
||||
decode s
|
||||
| Bytes.length s == NaClSizes.sign = Just (Signature s)
|
||||
| Bytes.length s == NaClSizes.sign = Just $ Signature s
|
||||
| otherwise = Nothing
|
||||
encode = coerce
|
||||
|
||||
@ -29,5 +29,6 @@ data NarSignature = NarSignature
|
||||
{ -- | The public key used to sign the archive.
|
||||
publicKey :: PublicKey
|
||||
, -- | The archive's signature.
|
||||
sig :: Signature
|
||||
} deriving (Eq, Ord)
|
||||
sig :: Signature
|
||||
}
|
||||
deriving (Eq, Ord)
|
||||
|
||||
@ -10,29 +10,35 @@ Description : Representation of Nix store paths.
|
||||
{-# LANGUAGE TypeInType #-} -- Needed for GHC 8.4.4 for some reason
|
||||
|
||||
module System.Nix.Internal.StorePath where
|
||||
import System.Nix.Hash
|
||||
( HashAlgorithm(Truncated, SHA256)
|
||||
, Digest
|
||||
, BaseEncoding(..)
|
||||
, encodeInBase
|
||||
, decodeBase
|
||||
, SomeNamedDigest
|
||||
)
|
||||
import System.Nix.Hash ( HashAlgorithm
|
||||
( Truncated
|
||||
, SHA256
|
||||
)
|
||||
, Digest
|
||||
, BaseEncoding(..)
|
||||
, encodeInBase
|
||||
, decodeBase
|
||||
, SomeNamedDigest
|
||||
)
|
||||
|
||||
|
||||
import qualified System.Nix.Internal.Base32 as Nix.Base32 (digits32)
|
||||
import qualified System.Nix.Internal.Base32 as Nix.Base32
|
||||
( digits32 )
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Char8 as Bytes.Char8
|
||||
import qualified Data.Char as Char
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as Text (encodeUtf8)
|
||||
import Data.Attoparsec.Text.Lazy (Parser, (<?>))
|
||||
import qualified Data.Attoparsec.Text.Lazy as Parser.Text.Lazy
|
||||
import qualified System.FilePath as FilePath
|
||||
import Data.Hashable (Hashable(..))
|
||||
import Data.HashSet (HashSet)
|
||||
import Data.ByteString ( ByteString )
|
||||
import qualified Data.ByteString.Char8 as Bytes.Char8
|
||||
import qualified Data.Char as Char
|
||||
import Data.Text ( Text )
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as Text
|
||||
( encodeUtf8 )
|
||||
import Data.Attoparsec.Text.Lazy ( Parser
|
||||
, (<?>)
|
||||
)
|
||||
import qualified Data.Attoparsec.Text.Lazy as Parser.Text.Lazy
|
||||
import qualified System.FilePath as FilePath
|
||||
import Data.Hashable ( Hashable(..) )
|
||||
import Data.HashSet ( HashSet )
|
||||
|
||||
-- | A path in a Nix store.
|
||||
--
|
||||
@ -53,7 +59,8 @@ data StorePath = StorePath
|
||||
storePathName :: !StorePathName
|
||||
, -- | Root of the store
|
||||
storePathRoot :: !FilePath
|
||||
} deriving (Eq, Ord)
|
||||
}
|
||||
deriving (Eq, Ord)
|
||||
|
||||
instance Hashable StorePath where
|
||||
hashWithSalt s StorePath{..} =
|
||||
@ -142,42 +149,31 @@ validStorePathNameChar c =
|
||||
type RawFilePath = ByteString
|
||||
|
||||
-- | Render a 'StorePath' as a 'RawFilePath'.
|
||||
storePathToRawFilePath
|
||||
:: StorePath
|
||||
-> RawFilePath
|
||||
storePathToRawFilePath :: StorePath -> RawFilePath
|
||||
storePathToRawFilePath StorePath{..} =
|
||||
root <> "/" <> hashPart <> "-" <> name
|
||||
where
|
||||
root = Bytes.Char8.pack storePathRoot
|
||||
root = Bytes.Char8.pack storePathRoot
|
||||
hashPart = Text.encodeUtf8 $ encodeInBase Base32 storePathHash
|
||||
name = Text.encodeUtf8 $ unStorePathName storePathName
|
||||
name = Text.encodeUtf8 $ unStorePathName storePathName
|
||||
|
||||
-- | Render a 'StorePath' as a 'FilePath'.
|
||||
storePathToFilePath
|
||||
:: StorePath
|
||||
-> FilePath
|
||||
storePathToFilePath :: StorePath -> FilePath
|
||||
storePathToFilePath = Bytes.Char8.unpack . storePathToRawFilePath
|
||||
|
||||
-- | Render a 'StorePath' as a 'Text'.
|
||||
storePathToText
|
||||
:: StorePath
|
||||
-> Text
|
||||
storePathToText :: StorePath -> Text
|
||||
storePathToText = Text.pack . Bytes.Char8.unpack . storePathToRawFilePath
|
||||
|
||||
-- | Build `narinfo` suffix from `StorePath` which
|
||||
-- can be used to query binary caches.
|
||||
storePathToNarInfo
|
||||
:: StorePath
|
||||
-> Bytes.Char8.ByteString
|
||||
storePathToNarInfo :: StorePath -> Bytes.Char8.ByteString
|
||||
storePathToNarInfo StorePath{..} =
|
||||
Text.encodeUtf8 $ encodeInBase Base32 storePathHash <> ".narinfo"
|
||||
|
||||
-- | Parse `StorePath` from `Bytes.Char8.ByteString`, checking
|
||||
-- that store directory matches `expectedRoot`.
|
||||
parsePath
|
||||
:: FilePath
|
||||
-> Bytes.Char8.ByteString
|
||||
-> Either String StorePath
|
||||
parsePath :: FilePath -> Bytes.Char8.ByteString -> Either String StorePath
|
||||
parsePath expectedRoot x =
|
||||
let
|
||||
(rootDir, fname) = FilePath.splitFileName . Bytes.Char8.unpack $ x
|
||||
@ -196,26 +192,31 @@ parsePath expectedRoot x =
|
||||
|
||||
pathParser :: FilePath -> Parser StorePath
|
||||
pathParser expectedRoot = do
|
||||
_ <- Parser.Text.Lazy.string (Text.pack expectedRoot)
|
||||
<?> "Store root mismatch" -- e.g. /nix/store
|
||||
_ <-
|
||||
Parser.Text.Lazy.string (Text.pack expectedRoot)
|
||||
<?> "Store root mismatch" -- e.g. /nix/store
|
||||
|
||||
_ <- Parser.Text.Lazy.char '/'
|
||||
<?> "Expecting path separator"
|
||||
<?> "Expecting path separator"
|
||||
|
||||
digest <- decodeBase Base32
|
||||
digest <-
|
||||
decodeBase Base32
|
||||
<$> Parser.Text.Lazy.takeWhile1 (`elem` Nix.Base32.digits32)
|
||||
<?> "Invalid Base32 part"
|
||||
<?> "Invalid Base32 part"
|
||||
|
||||
_ <- Parser.Text.Lazy.char '-'
|
||||
<?> "Expecting dash (path name separator)"
|
||||
_ <- Parser.Text.Lazy.char '-' <?> "Expecting dash (path name separator)"
|
||||
|
||||
c0 <- Parser.Text.Lazy.satisfy (\c -> c /= '.' && validStorePathNameChar c)
|
||||
<?> "Leading path name character is a dot or invalid character"
|
||||
c0 <-
|
||||
Parser.Text.Lazy.satisfy (\c -> c /= '.' && validStorePathNameChar c)
|
||||
<?> "Leading path name character is a dot or invalid character"
|
||||
|
||||
rest <- Parser.Text.Lazy.takeWhile validStorePathNameChar
|
||||
<?> "Path name contains invalid character"
|
||||
rest <-
|
||||
Parser.Text.Lazy.takeWhile validStorePathNameChar
|
||||
<?> "Path name contains invalid character"
|
||||
|
||||
let name = makeStorePathName $ Text.cons c0 rest
|
||||
|
||||
either fail return
|
||||
$ StorePath <$> digest <*> name <*> pure expectedRoot
|
||||
either
|
||||
fail
|
||||
pure
|
||||
(StorePath <$> digest <*> name <*> pure expectedRoot)
|
||||
|
||||
@ -9,7 +9,8 @@ Maintainer : Shea Levy <shea@shealevy.com>
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
|
||||
module System.Nix.Nar (
|
||||
module System.Nix.Nar
|
||||
(
|
||||
|
||||
-- * Encoding and Decoding NAR archives
|
||||
buildNarIO
|
||||
@ -27,15 +28,16 @@ module System.Nix.Nar (
|
||||
-- * Internal
|
||||
, Nar.streamNarIO
|
||||
, Nar.runParser
|
||||
) where
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Control.Concurrent as Concurrent
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified System.IO as IO
|
||||
import qualified Control.Concurrent as Concurrent
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified System.IO as IO
|
||||
|
||||
import qualified System.Nix.Internal.Nar.Effects as Nar
|
||||
import qualified System.Nix.Internal.Nar.Parser as Nar
|
||||
import qualified System.Nix.Internal.Nar.Streamer as Nar
|
||||
import qualified System.Nix.Internal.Nar.Effects as Nar
|
||||
import qualified System.Nix.Internal.Nar.Parser as Nar
|
||||
import qualified System.Nix.Internal.Nar.Streamer as Nar
|
||||
|
||||
|
||||
-- For a description of the NAR format, see Eelco's thesis
|
||||
@ -64,7 +66,4 @@ unpackNarIO
|
||||
-> IO.Handle
|
||||
-> FilePath
|
||||
-> IO (Either String ())
|
||||
unpackNarIO effs =
|
||||
Nar.runParser
|
||||
effs
|
||||
Nar.parseNar
|
||||
unpackNarIO effs = Nar.runParser effs Nar.parseNar
|
||||
|
||||
@ -2,41 +2,50 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module System.Nix.ReadonlyStore where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.HashSet as HS
|
||||
|
||||
import Data.ByteString ( ByteString )
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.HashSet as HS
|
||||
import Data.Text.Encoding
|
||||
import System.Nix.Hash
|
||||
import System.Nix.StorePath
|
||||
|
||||
makeStorePath :: forall hashAlgo . (NamedAlgo hashAlgo)
|
||||
|
||||
makeStorePath
|
||||
:: forall hashAlgo
|
||||
. (NamedAlgo hashAlgo)
|
||||
=> FilePath
|
||||
-> ByteString
|
||||
-> Digest hashAlgo
|
||||
-> StorePathName
|
||||
-> StorePath
|
||||
makeStorePath fp ty h nm = StorePath storeHash nm fp
|
||||
where
|
||||
storeHash = hash s
|
||||
where
|
||||
storeHash = hash s
|
||||
|
||||
s =
|
||||
BS.intercalate ":" $
|
||||
ty:fmap encodeUtf8
|
||||
[ algoName @hashAlgo
|
||||
, encodeInBase Base16 h
|
||||
, T.pack fp
|
||||
, unStorePathName nm
|
||||
]
|
||||
s =
|
||||
BS.intercalate ":" $
|
||||
ty:fmap encodeUtf8
|
||||
[ algoName @hashAlgo
|
||||
, encodeInBase Base16 h
|
||||
, T.pack fp
|
||||
, unStorePathName nm
|
||||
]
|
||||
|
||||
makeTextPath :: FilePath -> StorePathName -> Digest 'SHA256 -> StorePathSet -> StorePath
|
||||
makeTextPath
|
||||
:: FilePath -> StorePathName -> Digest 'SHA256 -> StorePathSet -> StorePath
|
||||
makeTextPath fp nm h refs = makeStorePath fp ty h nm
|
||||
where
|
||||
ty = BS.intercalate ":" ("text" : map storePathToRawFilePath (HS.toList refs))
|
||||
where
|
||||
ty =
|
||||
BS.intercalate ":" ("text" : map storePathToRawFilePath (HS.toList refs))
|
||||
|
||||
makeFixedOutputPath :: forall hashAlgo . (ValidAlgo hashAlgo, NamedAlgo hashAlgo)
|
||||
makeFixedOutputPath
|
||||
:: forall hashAlgo
|
||||
. (ValidAlgo hashAlgo, NamedAlgo hashAlgo)
|
||||
=> FilePath
|
||||
-> Bool
|
||||
-> Digest hashAlgo
|
||||
@ -44,10 +53,17 @@ makeFixedOutputPath :: forall hashAlgo . (ValidAlgo hashAlgo, NamedAlgo hashAlgo
|
||||
-> StorePath
|
||||
makeFixedOutputPath fp recursive h =
|
||||
if recursive && (algoName @hashAlgo) == "sha256"
|
||||
then makeStorePath fp "source" h
|
||||
then makeStorePath fp "source" h
|
||||
else makeStorePath fp "output:out" h'
|
||||
where
|
||||
h' = hash @'SHA256 $ "fixed:out:" <> encodeUtf8 (algoName @hashAlgo) <> (if recursive then ":r:" else ":") <> encodeUtf8 (encodeInBase Base16 h) <> ":"
|
||||
h' =
|
||||
hash @ 'SHA256
|
||||
$ "fixed:out:"
|
||||
<> encodeUtf8 (algoName @hashAlgo)
|
||||
<> (if recursive then ":r:" else ":")
|
||||
<> encodeUtf8 (encodeInBase Base16 h)
|
||||
<> ":"
|
||||
|
||||
computeStorePathForText :: FilePath -> StorePathName -> ByteString -> (StorePathSet -> StorePath)
|
||||
computeStorePathForText
|
||||
:: FilePath -> StorePathName -> ByteString -> (StorePathSet -> StorePath)
|
||||
computeStorePathForText fp nm = makeTextPath fp nm . hash
|
||||
|
||||
@ -4,6 +4,7 @@ Description : Nix-relevant interfaces to NaCl signatures.
|
||||
module System.Nix.Signature
|
||||
( Signature
|
||||
, NarSignature(..)
|
||||
) where
|
||||
)
|
||||
where
|
||||
|
||||
import System.Nix.Internal.Signature
|
||||
import System.Nix.Internal.Signature
|
||||
|
||||
@ -21,6 +21,7 @@ module System.Nix.StorePath
|
||||
, -- * Parsing 'StorePath's
|
||||
parsePath
|
||||
, pathParser
|
||||
) where
|
||||
)
|
||||
where
|
||||
|
||||
import System.Nix.Internal.StorePath
|
||||
import System.Nix.Internal.StorePath
|
||||
|
||||
@ -3,12 +3,15 @@ Description : Metadata about Nix store paths.
|
||||
-}
|
||||
module System.Nix.StorePathMetadata where
|
||||
|
||||
import System.Nix.StorePath (StorePath, StorePathSet, ContentAddressableAddress)
|
||||
import System.Nix.Hash (SomeNamedDigest)
|
||||
import Data.Set (Set)
|
||||
import Data.Time (UTCTime)
|
||||
import Data.Word (Word64)
|
||||
import System.Nix.Signature (NarSignature)
|
||||
import System.Nix.StorePath ( StorePath
|
||||
, StorePathSet
|
||||
, ContentAddressableAddress
|
||||
)
|
||||
import System.Nix.Hash ( SomeNamedDigest )
|
||||
import Data.Set ( Set )
|
||||
import Data.Time ( UTCTime )
|
||||
import Data.Word ( Word64 )
|
||||
import System.Nix.Signature ( NarSignature )
|
||||
|
||||
-- | Metadata about a 'StorePath'
|
||||
data StorePathMetadata = StorePathMetadata
|
||||
|
||||
@ -4,9 +4,9 @@
|
||||
|
||||
module Arbitrary where
|
||||
|
||||
import Control.Monad (replicateM)
|
||||
import qualified Data.ByteString.Char8 as BSC
|
||||
import qualified Data.Text as T
|
||||
import Control.Monad ( replicateM )
|
||||
import qualified Data.ByteString.Char8 as BSC
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Test.Tasty.QuickCheck
|
||||
|
||||
@ -22,15 +22,14 @@ nonEmptyString :: Gen String
|
||||
nonEmptyString = listOf1 genSafeChar
|
||||
|
||||
dir :: Gen String
|
||||
dir = ('/':) <$> (listOf1 $ elements $ ('/':['a'..'z']))
|
||||
dir = ('/':) <$> (listOf1 $ elements $ '/':['a'..'z'])
|
||||
|
||||
instance Arbitrary StorePathName where
|
||||
arbitrary = StorePathName . T.pack
|
||||
<$> ((:) <$> s1 <*> listOf sn)
|
||||
where
|
||||
alphanum = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']
|
||||
s1 = elements $ alphanum ++ "+-_?="
|
||||
sn = elements $ alphanum ++ "+-._?="
|
||||
arbitrary = StorePathName . T.pack <$> ((:) <$> s1 <*> listOf sn)
|
||||
where
|
||||
alphanum = ['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9']
|
||||
s1 = elements $ alphanum <> "+-_?="
|
||||
sn = elements $ alphanum <> "+-._?="
|
||||
|
||||
instance Arbitrary (Digest StorePathHashAlgo) where
|
||||
arbitrary = hash . BSC.pack <$> arbitrary
|
||||
@ -41,19 +40,17 @@ instance Arbitrary (Digest 'SHA256) where
|
||||
newtype NixLike = NixLike {getNixLike :: StorePath}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Arbitrary (NixLike) where
|
||||
arbitrary = NixLike <$>
|
||||
(StorePath
|
||||
<$> arbitraryTruncatedDigest
|
||||
<*> arbitrary
|
||||
<*> pure "/nix/store")
|
||||
where
|
||||
-- 160-bit hash, 20 bytes, 32 chars in base32
|
||||
arbitraryTruncatedDigest = Digest . BSC.pack
|
||||
<$> replicateM 20 genSafeChar
|
||||
instance Arbitrary NixLike where
|
||||
arbitrary =
|
||||
NixLike
|
||||
<$> (StorePath
|
||||
<$> arbitraryTruncatedDigest
|
||||
<*> arbitrary
|
||||
<*> pure "/nix/store"
|
||||
)
|
||||
where
|
||||
-- 160-bit hash, 20 bytes, 32 chars in base32
|
||||
arbitraryTruncatedDigest = Digest . BSC.pack <$> replicateM 20 genSafeChar
|
||||
|
||||
instance Arbitrary StorePath where
|
||||
arbitrary = StorePath
|
||||
<$> arbitrary
|
||||
<*> arbitrary
|
||||
<*> dir
|
||||
arbitrary = StorePath <$> arbitrary <*> arbitrary <*> dir
|
||||
|
||||
@ -1,10 +1,14 @@
|
||||
|
||||
module Derivation where
|
||||
|
||||
import Test.Tasty (TestTree, testGroup)
|
||||
import Test.Tasty.Golden (goldenVsFile)
|
||||
import Test.Tasty ( TestTree
|
||||
, testGroup
|
||||
)
|
||||
import Test.Tasty.Golden ( goldenVsFile )
|
||||
|
||||
import System.Nix.Derivation (parseDerivation, buildDerivation)
|
||||
import System.Nix.Derivation ( parseDerivation
|
||||
, buildDerivation
|
||||
)
|
||||
|
||||
import qualified Data.Attoparsec.Text.Lazy
|
||||
import qualified Data.Text.IO
|
||||
@ -14,25 +18,30 @@ import qualified Data.Text.Lazy.Builder
|
||||
processDerivation :: FilePath -> FilePath -> IO ()
|
||||
processDerivation source dest = do
|
||||
contents <- Data.Text.IO.readFile source
|
||||
case Data.Attoparsec.Text.Lazy.parseOnly (parseDerivation "/nix/store") contents of
|
||||
case
|
||||
Data.Attoparsec.Text.Lazy.parseOnly
|
||||
(parseDerivation "/nix/store")
|
||||
contents
|
||||
of
|
||||
Left e -> error e
|
||||
Right drv ->
|
||||
Data.Text.IO.writeFile dest
|
||||
. Data.Text.Lazy.toStrict
|
||||
. Data.Text.Lazy.Builder.toLazyText
|
||||
$ buildDerivation drv
|
||||
Data.Text.IO.writeFile dest
|
||||
. Data.Text.Lazy.toStrict
|
||||
. Data.Text.Lazy.Builder.toLazyText
|
||||
$ buildDerivation drv
|
||||
|
||||
test_derivation :: TestTree
|
||||
test_derivation = testGroup "golden" $ map mk [0..1]
|
||||
where
|
||||
mk :: Int -> TestTree
|
||||
mk n =
|
||||
let
|
||||
fp = "tests/samples/example"
|
||||
drv = (fp ++ show n ++ ".drv")
|
||||
act = (fp ++ show n ++ ".actual")
|
||||
in
|
||||
goldenVsFile
|
||||
("derivation roundtrip of " ++ drv)
|
||||
drv act (processDerivation drv act)
|
||||
|
||||
test_derivation =
|
||||
testGroup "golden" $ fmap mk [0 .. 1]
|
||||
where
|
||||
mk :: Int -> TestTree
|
||||
mk n =
|
||||
goldenVsFile
|
||||
("derivation roundtrip of " <> drv)
|
||||
drv
|
||||
act
|
||||
(processDerivation drv act)
|
||||
where
|
||||
drv = fp <> show n <> ".drv"
|
||||
act = fp <> show n <> ".actual"
|
||||
fp = "tests/samples/example"
|
||||
|
||||
@ -24,10 +24,8 @@ prop_storePathRoundtrip' x =
|
||||
|
||||
prop_storePathRoundtripParser :: NixLike -> NixLike -> Property
|
||||
prop_storePathRoundtripParser (_ :: NixLike) = \(NixLike x) ->
|
||||
(Data.Attoparsec.Text.Lazy.parseOnly (pathParser (storePathRoot x))
|
||||
$ storePathToText x) === Right x
|
||||
(Data.Attoparsec.Text.Lazy.parseOnly (pathParser $ storePathRoot x) $ storePathToText x) === Right x
|
||||
|
||||
prop_storePathRoundtripParser' :: StorePath -> Property
|
||||
prop_storePathRoundtripParser' x =
|
||||
(Data.Attoparsec.Text.Lazy.parseOnly (pathParser (storePathRoot x))
|
||||
$ storePathToText x) === Right x
|
||||
(Data.Attoparsec.Text.Lazy.parseOnly (pathParser $ storePathRoot x) $ storePathToText x) === Right x
|
||||
|
||||
@ -7,8 +7,7 @@
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module System.Nix.Store.Remote
|
||||
(
|
||||
addToStore
|
||||
( addToStore
|
||||
, addTextToStore
|
||||
, addSignatures
|
||||
, addIndirectRoot
|
||||
@ -34,18 +33,34 @@ module System.Nix.Store.Remote
|
||||
, verifyStore
|
||||
, module System.Nix.Store.Remote.Types
|
||||
)
|
||||
where
|
||||
where
|
||||
|
||||
import Control.Monad (void, unless, when)
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Data.Map.Strict (Map)
|
||||
import Data.Text (Text)
|
||||
import Control.Monad ( void
|
||||
, unless
|
||||
, when
|
||||
)
|
||||
import Data.ByteString.Lazy ( ByteString )
|
||||
import Data.Map.Strict ( Map )
|
||||
import Data.Text ( Text )
|
||||
|
||||
import Nix.Derivation (Derivation)
|
||||
import System.Nix.Build (BuildMode, BuildResult)
|
||||
import System.Nix.Hash (Digest, NamedAlgo, ValidAlgo, SomeNamedDigest(..), BaseEncoding(Base32))
|
||||
import System.Nix.StorePath (StorePath, StorePathName, StorePathSet, StorePathHashAlgo)
|
||||
import System.Nix.StorePathMetadata (StorePathMetadata(..), StorePathTrust(..))
|
||||
import Nix.Derivation ( Derivation )
|
||||
import System.Nix.Build ( BuildMode
|
||||
, BuildResult
|
||||
)
|
||||
import System.Nix.Hash ( Digest
|
||||
, NamedAlgo
|
||||
, ValidAlgo
|
||||
, SomeNamedDigest(..)
|
||||
, BaseEncoding(Base32)
|
||||
)
|
||||
import System.Nix.StorePath ( StorePath
|
||||
, StorePathName
|
||||
, StorePathSet
|
||||
, StorePathHashAlgo
|
||||
)
|
||||
import System.Nix.StorePathMetadata ( StorePathMetadata(..)
|
||||
, StorePathTrust(..)
|
||||
)
|
||||
|
||||
import qualified Data.Binary.Put
|
||||
import qualified Data.ByteString.Lazy
|
||||
@ -68,22 +83,22 @@ type CheckFlag = Bool
|
||||
type SubstituteFlag = Bool
|
||||
|
||||
-- | Pack `FilePath` as `Nar` and add it to the store.
|
||||
addToStore :: forall a. (ValidAlgo a, NamedAlgo a)
|
||||
=> StorePathName -- ^ Name part of the newly created `StorePath`
|
||||
-> FilePath -- ^ Local `FilePath` to add
|
||||
-> Bool -- ^ Add target directory recursively
|
||||
-> (FilePath -> Bool) -- ^ Path filter function
|
||||
-> RepairFlag -- ^ Only used by local store backend
|
||||
-> MonadStore StorePath
|
||||
addToStore
|
||||
:: forall a
|
||||
. (ValidAlgo a, NamedAlgo a)
|
||||
=> StorePathName -- ^ Name part of the newly created `StorePath`
|
||||
-> FilePath -- ^ Local `FilePath` to add
|
||||
-> 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
|
||||
|
||||
runOpArgsIO AddToStore $ \yield -> do
|
||||
yield $ Data.ByteString.Lazy.toStrict $ Data.Binary.Put.runPut $ do
|
||||
putText $ System.Nix.StorePath.unStorePathName name
|
||||
|
||||
putBool
|
||||
$ not
|
||||
$ System.Nix.Hash.algoName @a == "sha256" && recursive
|
||||
putBool $ not $ System.Nix.Hash.algoName @a == "sha256" && recursive
|
||||
|
||||
putBool recursive
|
||||
|
||||
@ -97,22 +112,22 @@ addToStore name pth recursive _pathFilter _repair = do
|
||||
--
|
||||
-- Reference accepts repair but only uses it
|
||||
-- to throw error in case of remote talking to nix-daemon.
|
||||
addTextToStore :: Text -- ^ Name of the text
|
||||
-> Text -- ^ Actual text to add
|
||||
-> StorePathSet -- ^ Set of `StorePath`s that the added text references
|
||||
-> RepairFlag -- ^ Repair flag, must be `False` in case of remote backend
|
||||
-> MonadStore StorePath
|
||||
addTextToStore
|
||||
:: Text -- ^ Name of the text
|
||||
-> Text -- ^ Actual text to add
|
||||
-> StorePathSet -- ^ Set of `StorePath`s that the added text references
|
||||
-> RepairFlag -- ^ Repair flag, must be `False` in case of remote backend
|
||||
-> MonadStore StorePath
|
||||
addTextToStore name text references' repair = do
|
||||
when repair $ error "repairing is not supported when building through the Nix daemon"
|
||||
when repair
|
||||
$ error "repairing is not supported when building through the Nix daemon"
|
||||
runOpArgs AddTextToStore $ do
|
||||
putText name
|
||||
putText text
|
||||
putPaths references'
|
||||
sockGetPath
|
||||
|
||||
addSignatures :: StorePath
|
||||
-> [ByteString]
|
||||
-> MonadStore ()
|
||||
addSignatures :: StorePath -> [ByteString] -> MonadStore ()
|
||||
addSignatures p signatures = do
|
||||
void $ simpleOpArgs AddSignatures $ do
|
||||
putPath p
|
||||
@ -132,18 +147,17 @@ addTempRoot pn = do
|
||||
-- | Build paths if they are an actual derivations.
|
||||
--
|
||||
-- If derivation output paths are already valid, do nothing.
|
||||
buildPaths :: StorePathSet
|
||||
-> BuildMode
|
||||
-> MonadStore ()
|
||||
buildPaths :: StorePathSet -> BuildMode -> MonadStore ()
|
||||
buildPaths ps bm = do
|
||||
void $ simpleOpArgs BuildPaths $ do
|
||||
putPaths ps
|
||||
putInt $ fromEnum bm
|
||||
|
||||
buildDerivation :: StorePath
|
||||
-> Derivation StorePath Text
|
||||
-> BuildMode
|
||||
-> MonadStore BuildResult
|
||||
buildDerivation
|
||||
:: StorePath
|
||||
-> Derivation StorePath Text
|
||||
-> BuildMode
|
||||
-> MonadStore BuildResult
|
||||
buildDerivation p drv buildMode = do
|
||||
runOpArgs BuildDerivation $ do
|
||||
putPath p
|
||||
@ -166,30 +180,33 @@ ensurePath pn = do
|
||||
findRoots :: MonadStore (Map ByteString StorePath)
|
||||
findRoots = do
|
||||
runOp FindRoots
|
||||
sd <- getStoreDir
|
||||
res <- getSocketIncremental
|
||||
sd <- getStoreDir
|
||||
res <-
|
||||
getSocketIncremental
|
||||
$ getMany
|
||||
$ (,) <$> (Data.ByteString.Lazy.fromStrict <$> getByteStringLen)
|
||||
<*> getPath sd
|
||||
$ (,)
|
||||
<$> (Data.ByteString.Lazy.fromStrict <$> getByteStringLen)
|
||||
<*> getPath sd
|
||||
|
||||
r <- catRights res
|
||||
return $ Data.Map.Strict.fromList r
|
||||
where
|
||||
catRights :: [(a, Either String b)] -> MonadStore [(a, b)]
|
||||
catRights = mapM ex
|
||||
where
|
||||
catRights :: [(a, Either String b)] -> MonadStore [(a, b)]
|
||||
catRights = mapM ex
|
||||
|
||||
ex :: (a, Either [Char] b) -> MonadStore (a, b)
|
||||
ex (x, Right y) = return (x, y)
|
||||
ex (_x , Left e) = error $ "Unable to decode root: " ++ e
|
||||
ex :: (a, Either [Char] b) -> MonadStore (a, b)
|
||||
ex (x , Right y) = return (x, y)
|
||||
ex (_x, Left e ) = error $ "Unable to decode root: " ++ e
|
||||
|
||||
isValidPathUncached :: StorePath -> MonadStore Bool
|
||||
isValidPathUncached p = do
|
||||
simpleOpArgs IsValidPath $ putPath p
|
||||
|
||||
-- | Query valid paths from set, optionally try to use substitutes.
|
||||
queryValidPaths :: StorePathSet -- ^ Set of `StorePath`s to query
|
||||
-> SubstituteFlag -- ^ Try substituting missing paths when `True`
|
||||
-> MonadStore StorePathSet
|
||||
queryValidPaths
|
||||
:: StorePathSet -- ^ Set of `StorePath`s to query
|
||||
-> SubstituteFlag -- ^ Try substituting missing paths when `True`
|
||||
-> MonadStore StorePathSet
|
||||
queryValidPaths ps substitute = do
|
||||
runOpArgs QueryValidPaths $ do
|
||||
putPaths ps
|
||||
@ -203,12 +220,10 @@ queryAllValidPaths = do
|
||||
|
||||
querySubstitutablePaths :: StorePathSet -> MonadStore StorePathSet
|
||||
querySubstitutablePaths ps = do
|
||||
runOpArgs QuerySubstitutablePaths $ do
|
||||
putPaths ps
|
||||
runOpArgs QuerySubstitutablePaths $ putPaths ps
|
||||
sockGetPaths
|
||||
|
||||
queryPathInfoUncached :: StorePath
|
||||
-> MonadStore StorePathMetadata
|
||||
queryPathInfoUncached :: StorePath -> MonadStore StorePathMetadata
|
||||
queryPathInfoUncached path = do
|
||||
runOpArgs QueryPathInfo $ do
|
||||
putPath path
|
||||
@ -219,74 +234,77 @@ queryPathInfoUncached path = do
|
||||
deriverPath <- sockGetPathMay
|
||||
|
||||
narHashText <- Data.Text.Encoding.decodeUtf8 <$> sockGetStr
|
||||
let narHash = case System.Nix.Hash.decodeBase @'System.Nix.Hash.SHA256 Base32 narHashText of
|
||||
Left e -> error e
|
||||
let
|
||||
narHash =
|
||||
case
|
||||
System.Nix.Hash.decodeBase @'System.Nix.Hash.SHA256 Base32 narHashText
|
||||
of
|
||||
Left e -> error e
|
||||
Right x -> SomeDigest x
|
||||
|
||||
references <- sockGetPaths
|
||||
references <- sockGetPaths
|
||||
registrationTime <- sockGet getTime
|
||||
narBytes <- Just <$> sockGetInt
|
||||
ultimate <- sockGetBool
|
||||
narBytes <- Just <$> sockGetInt
|
||||
ultimate <- sockGetBool
|
||||
|
||||
_sigStrings <- map bsToText <$> sockGetStrings
|
||||
caString <- sockGetStr
|
||||
_sigStrings <- fmap bsToText <$> sockGetStrings
|
||||
caString <- sockGetStr
|
||||
|
||||
let
|
||||
-- XXX: signatures need pubkey from config
|
||||
sigs = Data.Set.empty
|
||||
|
||||
contentAddressableAddress =
|
||||
case System.Nix.Store.Remote.Parsers.parseContentAddressableAddress caString of
|
||||
Left e -> error e
|
||||
case
|
||||
System.Nix.Store.Remote.Parsers.parseContentAddressableAddress caString
|
||||
of
|
||||
Left e -> error e
|
||||
Right x -> Just x
|
||||
|
||||
trust = if ultimate then BuiltLocally
|
||||
else BuiltElsewhere
|
||||
trust = if ultimate then BuiltLocally else BuiltElsewhere
|
||||
|
||||
return $ StorePathMetadata {..}
|
||||
return $ StorePathMetadata{..}
|
||||
|
||||
queryReferrers :: StorePath -> MonadStore StorePathSet
|
||||
queryReferrers p = do
|
||||
runOpArgs QueryReferrers $ do
|
||||
putPath p
|
||||
runOpArgs QueryReferrers $ putPath p
|
||||
sockGetPaths
|
||||
|
||||
queryValidDerivers :: StorePath -> MonadStore StorePathSet
|
||||
queryValidDerivers p = do
|
||||
runOpArgs QueryValidDerivers $ do
|
||||
putPath p
|
||||
runOpArgs QueryValidDerivers $ putPath p
|
||||
sockGetPaths
|
||||
|
||||
queryDerivationOutputs :: StorePath -> MonadStore StorePathSet
|
||||
queryDerivationOutputs p = do
|
||||
runOpArgs QueryDerivationOutputs $
|
||||
putPath p
|
||||
runOpArgs QueryDerivationOutputs $ putPath p
|
||||
sockGetPaths
|
||||
|
||||
queryDerivationOutputNames :: StorePath -> MonadStore StorePathSet
|
||||
queryDerivationOutputNames p = do
|
||||
runOpArgs QueryDerivationOutputNames $
|
||||
putPath p
|
||||
runOpArgs QueryDerivationOutputNames $ putPath p
|
||||
sockGetPaths
|
||||
|
||||
queryPathFromHashPart :: Digest StorePathHashAlgo -> MonadStore StorePath
|
||||
queryPathFromHashPart storePathHash = do
|
||||
runOpArgs QueryPathFromHashPart $
|
||||
putByteStringLen
|
||||
$ Data.ByteString.Lazy.fromStrict
|
||||
$ Data.Text.Encoding.encodeUtf8
|
||||
$ System.Nix.Hash.encodeInBase Base32 storePathHash
|
||||
runOpArgs QueryPathFromHashPart
|
||||
$ putByteStringLen
|
||||
$ Data.ByteString.Lazy.fromStrict
|
||||
$ Data.Text.Encoding.encodeUtf8
|
||||
$ System.Nix.Hash.encodeInBase Base32 storePathHash
|
||||
sockGetPath
|
||||
|
||||
queryMissing :: StorePathSet
|
||||
-> MonadStore ( StorePathSet -- Paths that will be built
|
||||
, StorePathSet -- Paths that have substitutes
|
||||
, StorePathSet -- Unknown paths
|
||||
, Integer -- Download size
|
||||
, Integer) -- Nar size?
|
||||
queryMissing
|
||||
:: StorePathSet
|
||||
-> MonadStore
|
||||
( StorePathSet-- Paths that will be built
|
||||
, StorePathSet -- Paths that have substitutes
|
||||
, StorePathSet -- Unknown paths
|
||||
, Integer -- Download size
|
||||
, Integer -- Nar size?
|
||||
)
|
||||
queryMissing ps = do
|
||||
runOpArgs QueryMissing $ do
|
||||
putPaths ps
|
||||
runOpArgs QueryMissing $ putPaths ps
|
||||
|
||||
willBuild <- sockGetPaths
|
||||
willSubstitute <- sockGetPaths
|
||||
|
||||
@ -7,8 +7,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
|
||||
import Data.ByteString ( ByteString )
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
|
||||
putInt :: Integral a => a -> Put
|
||||
putInt = putWord64le . fromIntegral
|
||||
@ -31,12 +31,11 @@ putByteStringLen :: BSL.ByteString -> Put
|
||||
putByteStringLen x = do
|
||||
putInt len
|
||||
putLazyByteString x
|
||||
when (len `mod` 8 /= 0) $
|
||||
pad $ 8 - (len `mod` 8)
|
||||
where
|
||||
len :: Int
|
||||
len = fromIntegral $ BSL.length x
|
||||
pad count = sequence_ $ replicate count (putWord8 0)
|
||||
when (len `mod` 8 /= 0) $ pad $ 8 - (len `mod` 8)
|
||||
where
|
||||
len :: Int
|
||||
len = fromIntegral $ BSL.length x
|
||||
pad count = sequence_ $ replicate count (putWord8 0)
|
||||
|
||||
putByteStrings :: Foldable t => t BSL.ByteString -> Put
|
||||
putByteStrings = putMany putByteStringLen
|
||||
@ -44,10 +43,10 @@ putByteStrings = putMany putByteStringLen
|
||||
getByteStringLen :: Get ByteString
|
||||
getByteStringLen = do
|
||||
len <- getInt
|
||||
st <- getLazyByteString len
|
||||
st <- getLazyByteString len
|
||||
when (len `mod` 8 /= 0) $ do
|
||||
pads <- unpad $ fromIntegral $ 8 - (len `mod` 8)
|
||||
unless (all (==0) pads) $ fail $ "No zeroes" ++ show (st, len, pads)
|
||||
unless (all (== 0) pads) $ fail $ "No zeroes" ++ show (st, len, pads)
|
||||
return $ BSL.toStrict st
|
||||
where unpad x = sequence $ replicate x getWord8
|
||||
|
||||
|
||||
@ -4,42 +4,38 @@
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module System.Nix.Store.Remote.Builders (
|
||||
buildContentAddressableAddress
|
||||
) where
|
||||
module System.Nix.Store.Remote.Builders
|
||||
( buildContentAddressableAddress
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Text.Lazy (Text)
|
||||
import System.Nix.Hash ( Digest
|
||||
, SomeNamedDigest(SomeDigest)
|
||||
, BaseEncoding(Base32)
|
||||
)
|
||||
import System.Nix.StorePath (ContentAddressableAddress(..))
|
||||
import Data.Text.Lazy ( Text )
|
||||
import System.Nix.Hash ( Digest
|
||||
, SomeNamedDigest(SomeDigest)
|
||||
, BaseEncoding(Base32)
|
||||
)
|
||||
import System.Nix.StorePath ( ContentAddressableAddress(..)
|
||||
)
|
||||
|
||||
import Data.Text.Lazy.Builder (Builder)
|
||||
import Data.Text.Lazy.Builder ( Builder )
|
||||
import qualified Data.Text.Lazy.Builder
|
||||
|
||||
import qualified System.Nix.Hash
|
||||
|
||||
-- | Marshall `ContentAddressableAddress` to `Text`
|
||||
-- in form suitable for remote protocol usage.
|
||||
buildContentAddressableAddress
|
||||
:: ContentAddressableAddress
|
||||
-> Text
|
||||
buildContentAddressableAddress :: ContentAddressableAddress -> Text
|
||||
buildContentAddressableAddress =
|
||||
Data.Text.Lazy.Builder.toLazyText . contentAddressableAddressBuilder
|
||||
|
||||
contentAddressableAddressBuilder
|
||||
:: ContentAddressableAddress
|
||||
-> Builder
|
||||
contentAddressableAddressBuilder :: ContentAddressableAddress -> Builder
|
||||
contentAddressableAddressBuilder (Text digest) =
|
||||
"text:"
|
||||
<> digestBuilder digest
|
||||
"text:" <> digestBuilder digest
|
||||
contentAddressableAddressBuilder (Fixed _narHashMode (SomeDigest (digest :: Digest hashAlgo))) =
|
||||
"fixed:"
|
||||
"fixed:"
|
||||
<> (Data.Text.Lazy.Builder.fromText $ System.Nix.Hash.algoName @hashAlgo)
|
||||
<> digestBuilder digest
|
||||
|
||||
digestBuilder :: Digest a -> Builder
|
||||
digestBuilder =
|
||||
Data.Text.Lazy.Builder.fromText
|
||||
. System.Nix.Hash.encodeInBase Base32
|
||||
Data.Text.Lazy.Builder.fromText . System.Nix.Hash.encodeInBase Base32
|
||||
|
||||
@ -1,21 +1,25 @@
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
module System.Nix.Store.Remote.Logger (
|
||||
Logger(..)
|
||||
|
||||
module System.Nix.Store.Remote.Logger
|
||||
( Logger(..)
|
||||
, Field(..)
|
||||
, processOutput)
|
||||
where
|
||||
, processOutput
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader (ask)
|
||||
import Control.Monad.State (get)
|
||||
import Control.Monad.Reader ( asks )
|
||||
import Control.Monad.State ( get )
|
||||
import Data.Binary.Get
|
||||
|
||||
import Network.Socket.ByteString (recv)
|
||||
import Network.Socket.ByteString ( recv )
|
||||
|
||||
import System.Nix.Store.Remote.Binary
|
||||
import System.Nix.Store.Remote.Types
|
||||
import System.Nix.Store.Remote.Util
|
||||
|
||||
|
||||
controlParser :: Get Logger
|
||||
controlParser = do
|
||||
ctrl <- getInt
|
||||
@ -24,43 +28,51 @@ controlParser = do
|
||||
0x64617461 -> Read <$> getInt
|
||||
0x64617416 -> Write <$> getByteStringLen
|
||||
0x616c7473 -> pure Last
|
||||
0x63787470 -> flip Error <$> getByteStringLen <*> getInt
|
||||
0x53545254 -> StartActivity <$> getInt <*> getInt <*> getInt <*> getByteStringLen <*> getFields <*> getInt
|
||||
0x63787470 -> flip Error <$> getByteStringLen
|
||||
<*> getInt
|
||||
0x53545254 -> StartActivity <$> getInt
|
||||
<*> getInt
|
||||
<*> getInt
|
||||
<*> getByteStringLen
|
||||
<*> getFields
|
||||
<*> getInt
|
||||
0x53544f50 -> StopActivity <$> getInt
|
||||
0x52534c54 -> Result <$> getInt <*> getInt <*> getFields
|
||||
x -> fail $ "Invalid control message received:" ++ show x
|
||||
0x52534c54 -> Result <$> getInt
|
||||
<*> getInt
|
||||
<*> getFields
|
||||
x -> fail $ "Invalid control message received:" <> show x
|
||||
|
||||
processOutput :: MonadStore [Logger]
|
||||
processOutput = go decoder
|
||||
where decoder = runGetIncremental controlParser
|
||||
go :: Decoder Logger -> MonadStore [Logger]
|
||||
go (Done _leftover _consumed ctrl) = do
|
||||
case ctrl of
|
||||
e@(Error _ _) -> return [e]
|
||||
Last -> return [Last]
|
||||
Read _n -> do
|
||||
(mdata, _) <- get
|
||||
case mdata of
|
||||
Nothing -> throwError "No data to read provided"
|
||||
Just part -> do
|
||||
-- XXX: we should check/assert part size against n of (Read n)
|
||||
sockPut $ putByteStringLen part
|
||||
clearData
|
||||
where
|
||||
decoder = runGetIncremental controlParser
|
||||
go :: Decoder Logger -> MonadStore [Logger]
|
||||
go (Done _leftover _consumed ctrl) = do
|
||||
case ctrl of
|
||||
e@(Error _ _) -> return [e]
|
||||
Last -> return [Last]
|
||||
Read _n -> do
|
||||
(mdata, _) <- get
|
||||
case mdata of
|
||||
Nothing -> throwError "No data to read provided"
|
||||
Just part -> do
|
||||
-- XXX: we should check/assert part size against n of (Read n)
|
||||
sockPut $ putByteStringLen part
|
||||
clearData
|
||||
|
||||
next <- go decoder
|
||||
return $ next
|
||||
next <- go decoder
|
||||
return next
|
||||
|
||||
-- we should probably handle Read here as well
|
||||
x -> do
|
||||
next <- go decoder
|
||||
return $ x:next
|
||||
go (Partial k) = do
|
||||
soc <- storeSocket <$> ask
|
||||
chunk <- liftIO (Just <$> recv soc 8)
|
||||
go (k chunk)
|
||||
-- we should probably handle Read here as well
|
||||
x -> do
|
||||
next <- go decoder
|
||||
return $ x : next
|
||||
go (Partial k) = do
|
||||
soc <- asks storeSocket
|
||||
chunk <- liftIO (Just <$> recv soc 8)
|
||||
go (k chunk)
|
||||
|
||||
go (Fail _leftover _consumed msg) = do
|
||||
error msg
|
||||
go (Fail _leftover _consumed msg) = error msg
|
||||
|
||||
getFields :: Get [Field]
|
||||
getFields = do
|
||||
@ -73,4 +85,4 @@ getField = do
|
||||
case (typ :: Int) of
|
||||
0 -> LogInt <$> getInt
|
||||
1 -> LogStr <$> getByteStringLen
|
||||
x -> fail $ "Unknown log type: " ++ show x
|
||||
x -> fail $ "Unknown log type: " <> show x
|
||||
|
||||
@ -13,7 +13,7 @@ where
|
||||
import Control.Applicative ( (<|>) )
|
||||
import Data.Attoparsec.ByteString.Char8
|
||||
import Data.ByteString.Char8
|
||||
import Data.Text (Text)
|
||||
import Data.Text ( Text )
|
||||
import Data.Text.Encoding ( decodeUtf8 )
|
||||
import System.Nix.Hash
|
||||
import System.Nix.StorePath ( ContentAddressableAddress(..)
|
||||
@ -49,7 +49,8 @@ parseTypedDigest :: Parser (Either String SomeNamedDigest)
|
||||
parseTypedDigest = mkNamedDigest <$> parseHashType <*> parseHash
|
||||
|
||||
parseHashType :: Parser Text
|
||||
parseHashType = decodeUtf8 <$> ("sha256" <|> "sha512" <|> "sha1" <|> "md5") <* (":" <|> "-")
|
||||
parseHashType =
|
||||
decodeUtf8 <$> ("sha256" <|> "sha512" <|> "sha1" <|> "md5") <* (":" <|> "-")
|
||||
|
||||
parseHash :: Parser Text
|
||||
parseHash = decodeUtf8 <$> takeWhile1 (/= ':')
|
||||
|
||||
@ -1,17 +1,21 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
module System.Nix.Store.Remote.Protocol (
|
||||
WorkerOp(..)
|
||||
module System.Nix.Store.Remote.Protocol
|
||||
( WorkerOp(..)
|
||||
, simpleOp
|
||||
, simpleOpArgs
|
||||
, runOp
|
||||
, runOpArgs
|
||||
, runOpArgsIO
|
||||
, runStore
|
||||
, runStoreOpts) where
|
||||
, runStoreOpts
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Exception (bracket)
|
||||
|
||||
import Data.Bool ( bool )
|
||||
import Control.Exception ( bracket )
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State
|
||||
@ -22,15 +26,18 @@ import qualified Data.ByteString
|
||||
import qualified Data.ByteString.Char8
|
||||
import qualified Data.ByteString.Lazy
|
||||
|
||||
import Network.Socket (SockAddr(SockAddrUnix))
|
||||
import Network.Socket ( SockAddr(SockAddrUnix) )
|
||||
import qualified Network.Socket
|
||||
import Network.Socket.ByteString (recv, sendAll)
|
||||
import Network.Socket.ByteString ( recv
|
||||
, sendAll
|
||||
)
|
||||
|
||||
import System.Nix.Store.Remote.Binary
|
||||
import System.Nix.Store.Remote.Logger
|
||||
import System.Nix.Store.Remote.Types
|
||||
import System.Nix.Store.Remote.Util
|
||||
|
||||
|
||||
protoVersion :: Int
|
||||
protoVersion = 0x115
|
||||
-- major protoVersion & 0xFF00
|
||||
@ -115,37 +122,42 @@ opNum QueryMissing = 40
|
||||
|
||||
|
||||
simpleOp :: WorkerOp -> MonadStore Bool
|
||||
simpleOp op = do
|
||||
simpleOpArgs op $ return ()
|
||||
simpleOp op = simpleOpArgs op $ return ()
|
||||
|
||||
simpleOpArgs :: WorkerOp -> Put -> MonadStore Bool
|
||||
simpleOpArgs op args = do
|
||||
runOpArgs op args
|
||||
err <- gotError
|
||||
case err of
|
||||
True -> do
|
||||
bool
|
||||
sockGetBool
|
||||
(do
|
||||
Error _num msg <- head <$> getError
|
||||
throwError $ Data.ByteString.Char8.unpack msg
|
||||
False -> do
|
||||
sockGetBool
|
||||
)
|
||||
err
|
||||
|
||||
runOp :: WorkerOp -> MonadStore ()
|
||||
runOp op = runOpArgs op $ return ()
|
||||
|
||||
runOpArgs :: WorkerOp -> Put -> MonadStore ()
|
||||
runOpArgs op args = runOpArgsIO op (\encode -> encode $ Data.ByteString.Lazy.toStrict $ runPut args)
|
||||
runOpArgs op args =
|
||||
runOpArgsIO
|
||||
op
|
||||
(\encode -> encode $ Data.ByteString.Lazy.toStrict $ runPut args)
|
||||
|
||||
runOpArgsIO :: WorkerOp -> ((Data.ByteString.ByteString -> MonadStore ()) -> MonadStore ()) -> MonadStore ()
|
||||
runOpArgsIO
|
||||
:: WorkerOp
|
||||
-> ((Data.ByteString.ByteString -> MonadStore ()) -> MonadStore ())
|
||||
-> MonadStore ()
|
||||
runOpArgsIO op encoder = do
|
||||
|
||||
sockPut $ do
|
||||
putInt $ opNum op
|
||||
sockPut $ putInt $ opNum op
|
||||
|
||||
soc <- storeSocket <$> ask
|
||||
soc <- asks storeSocket
|
||||
encoder (liftIO . sendAll soc)
|
||||
|
||||
out <- processOutput
|
||||
modify (\(a, b) -> (a, b++out))
|
||||
modify (\(a, b) -> (a, b <> out))
|
||||
err <- gotError
|
||||
when err $ do
|
||||
Error _num msg <- head <$> getError
|
||||
@ -154,39 +166,44 @@ runOpArgsIO op encoder = do
|
||||
runStore :: MonadStore a -> IO (Either String a, [Logger])
|
||||
runStore = runStoreOpts defaultSockPath "/nix/store"
|
||||
|
||||
runStoreOpts :: FilePath -> FilePath -> MonadStore a -> IO (Either String a, [Logger])
|
||||
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
|
||||
where
|
||||
open path = do
|
||||
soc <-
|
||||
Network.Socket.socket
|
||||
Network.Socket.AF_UNIX
|
||||
Network.Socket.Stream
|
||||
0
|
||||
|
||||
Network.Socket.connect soc (SockAddrUnix path)
|
||||
return $ StoreConfig { storeSocket = soc
|
||||
, storeDir = storeRootDir }
|
||||
Network.Socket.connect soc (SockAddrUnix path)
|
||||
return StoreConfig
|
||||
{ storeSocket = soc
|
||||
, storeDir = storeRootDir
|
||||
}
|
||||
|
||||
greet = do
|
||||
sockPut $ putInt workerMagic1
|
||||
soc <- storeSocket <$> ask
|
||||
vermagic <- liftIO $ recv soc 16
|
||||
let (magic2, _daemonProtoVersion) =
|
||||
flip runGet (Data.ByteString.Lazy.fromStrict vermagic)
|
||||
$ (,) <$> (getInt :: Get Int)
|
||||
<*> (getInt :: Get Int)
|
||||
unless (magic2 == workerMagic2) $ error "Worker magic 2 mismatch"
|
||||
greet = do
|
||||
sockPut $ putInt workerMagic1
|
||||
soc <- asks storeSocket
|
||||
vermagic <- liftIO $ recv soc 16
|
||||
let
|
||||
(magic2, _daemonProtoVersion) =
|
||||
flip runGet (Data.ByteString.Lazy.fromStrict vermagic)
|
||||
$ (,)
|
||||
<$> (getInt :: Get Int)
|
||||
<*> (getInt :: Get Int)
|
||||
unless (magic2 == workerMagic2) $ error "Worker magic 2 mismatch"
|
||||
|
||||
sockPut $ putInt protoVersion -- clientVersion
|
||||
sockPut $ putInt (0 :: Int) -- affinity
|
||||
sockPut $ putInt (0 :: Int) -- obsolete reserveSpace
|
||||
sockPut $ putInt protoVersion -- clientVersion
|
||||
sockPut $ putInt (0 :: Int) -- affinity
|
||||
sockPut $ putInt (0 :: Int) -- obsolete reserveSpace
|
||||
|
||||
processOutput
|
||||
processOutput
|
||||
|
||||
run sock =
|
||||
fmap (\(res, (_data, logs)) -> (res, logs))
|
||||
$ flip runReaderT sock
|
||||
$ flip runStateT (Nothing, [])
|
||||
$ runExceptT (greet >> code)
|
||||
run sock =
|
||||
fmap (\(res, (_data, logs)) -> (res, logs))
|
||||
$ (`runReaderT` sock)
|
||||
$ (`runStateT` (Nothing, []))
|
||||
$ runExceptT (greet >> code)
|
||||
|
||||
@ -2,8 +2,8 @@
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
module System.Nix.Store.Remote.Types (
|
||||
MonadStore
|
||||
module System.Nix.Store.Remote.Types
|
||||
( MonadStore
|
||||
, StoreConfig(..)
|
||||
, Logger(..)
|
||||
, Field(..)
|
||||
@ -14,22 +14,27 @@ module System.Nix.Store.Remote.Types (
|
||||
, getError
|
||||
, setData
|
||||
, clearData
|
||||
) where
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
import Network.Socket (Socket)
|
||||
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
|
||||
, storeSocket :: Socket
|
||||
data StoreConfig = StoreConfig
|
||||
{ storeDir :: FilePath
|
||||
, storeSocket :: Socket
|
||||
}
|
||||
|
||||
type MonadStore a = ExceptT String (StateT (Maybe BSL.ByteString, [Logger]) (ReaderT StoreConfig IO)) a
|
||||
type MonadStore a
|
||||
= ExceptT
|
||||
String
|
||||
(StateT (Maybe BSL.ByteString, [Logger]) (ReaderT StoreConfig IO))
|
||||
a
|
||||
|
||||
type ActivityID = Int
|
||||
type ActivityParentID = Int
|
||||
|
||||
@ -8,17 +8,19 @@ 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.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
|
||||
import Data.ByteString ( ByteString )
|
||||
import qualified Data.ByteString.Char8 as BSC
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
|
||||
import Network.Socket.ByteString (recv, sendAll)
|
||||
import Network.Socket.ByteString ( recv
|
||||
, sendAll
|
||||
)
|
||||
|
||||
import Nix.Derivation
|
||||
|
||||
@ -32,23 +34,21 @@ import qualified Data.Map
|
||||
|
||||
genericIncremental :: (MonadIO m) => m (Maybe ByteString) -> Get a -> m a
|
||||
genericIncremental getsome parser = go decoder
|
||||
where
|
||||
decoder = runGetIncremental parser
|
||||
go (Done _leftover _consumed x) = do
|
||||
return x
|
||||
go (Partial k) = do
|
||||
chunk <- getsome
|
||||
go (k chunk)
|
||||
go (Fail _leftover _consumed msg) = do
|
||||
error msg
|
||||
where
|
||||
decoder = runGetIncremental parser
|
||||
go (Done _leftover _consumed x ) = return x
|
||||
go (Partial k ) = do
|
||||
chunk <- getsome
|
||||
go (k chunk)
|
||||
go (Fail _leftover _consumed msg) = error msg
|
||||
|
||||
getSocketIncremental :: Get a -> MonadStore a
|
||||
getSocketIncremental = genericIncremental sockGet8
|
||||
where
|
||||
sockGet8 :: MonadStore (Maybe BSC.ByteString)
|
||||
sockGet8 = do
|
||||
soc <- asks storeSocket
|
||||
liftIO $ Just <$> recv soc 8
|
||||
where
|
||||
sockGet8 :: MonadStore (Maybe BSC.ByteString)
|
||||
sockGet8 = do
|
||||
soc <- asks storeSocket
|
||||
liftIO $ Just <$> recv soc 8
|
||||
|
||||
sockPut :: Put -> MonadStore ()
|
||||
sockPut p = do
|
||||
@ -72,19 +72,22 @@ sockGetStrings = getSocketIncremental getByteStrings
|
||||
|
||||
sockGetPath :: MonadStore StorePath
|
||||
sockGetPath = do
|
||||
sd <- getStoreDir
|
||||
sd <- getStoreDir
|
||||
pth <- getSocketIncremental (getPath sd)
|
||||
case pth of
|
||||
Left e -> throwError e
|
||||
Right x -> return x
|
||||
either
|
||||
throwError
|
||||
return
|
||||
pth
|
||||
|
||||
sockGetPathMay :: MonadStore (Maybe StorePath)
|
||||
sockGetPathMay = do
|
||||
sd <- getStoreDir
|
||||
sd <- getStoreDir
|
||||
pth <- getSocketIncremental (getPath sd)
|
||||
return $ case pth of
|
||||
Left _e -> Nothing
|
||||
Right x -> Just x
|
||||
return $
|
||||
either
|
||||
(const Nothing)
|
||||
Just
|
||||
pth
|
||||
|
||||
sockGetPaths :: MonadStore StorePathSet
|
||||
sockGetPaths = do
|
||||
@ -113,20 +116,22 @@ getPath :: FilePath -> Get (Either String StorePath)
|
||||
getPath sd = parsePath sd <$> getByteStringLen
|
||||
|
||||
getPaths :: FilePath -> Get StorePathSet
|
||||
getPaths sd = Data.HashSet.fromList . rights . map (parsePath sd) <$> getByteStrings
|
||||
getPaths sd =
|
||||
Data.HashSet.fromList . rights . map (parsePath sd) <$> getByteStrings
|
||||
|
||||
putPath :: StorePath -> Put
|
||||
putPath = putByteStringLen . BSL.fromStrict . storePathToRawFilePath
|
||||
putPath = putByteStringLen . BSL.fromStrict . storePathToRawFilePath
|
||||
|
||||
putPaths :: StorePathSet -> Put
|
||||
putPaths = putByteStrings . Data.HashSet.toList . Data.HashSet.map (BSL.fromStrict . storePathToRawFilePath)
|
||||
putPaths = putByteStrings . Data.HashSet.toList . Data.HashSet.map
|
||||
(BSL.fromStrict . storePathToRawFilePath)
|
||||
|
||||
putBool :: Bool -> Put
|
||||
putBool True = putInt (1 :: Int)
|
||||
putBool False = putInt (0 :: Int)
|
||||
|
||||
getBool :: Get Bool
|
||||
getBool = (==1) <$> (getInt :: Get Int)
|
||||
getBool = (== 1) <$> (getInt :: Get Int)
|
||||
|
||||
putEnum :: (Enum a) => a -> Put
|
||||
putEnum = putInt . fromEnum
|
||||
@ -141,22 +146,23 @@ getTime :: Get UTCTime
|
||||
getTime = posixSecondsToUTCTime <$> getEnum
|
||||
|
||||
getBuildResult :: Get BuildResult
|
||||
getBuildResult = BuildResult
|
||||
<$> getEnum
|
||||
<*> (Just . bsToText <$> getByteStringLen)
|
||||
<*> getInt
|
||||
<*> getBool
|
||||
<*> getTime
|
||||
<*> getTime
|
||||
getBuildResult =
|
||||
BuildResult
|
||||
<$> getEnum
|
||||
<*> (Just . bsToText <$> getByteStringLen)
|
||||
<*> getInt
|
||||
<*> getBool
|
||||
<*> getTime
|
||||
<*> getTime
|
||||
|
||||
putDerivation :: Derivation StorePath Text -> Put
|
||||
putDerivation Derivation{..} = do
|
||||
flip putMany (Data.Map.toList outputs)
|
||||
$ \(outputName, DerivationOutput{..}) -> do
|
||||
putText outputName
|
||||
putPath path
|
||||
putText hashAlgo
|
||||
putText hash
|
||||
putText outputName
|
||||
putPath path
|
||||
putText hashAlgo
|
||||
putText hash
|
||||
|
||||
putMany putPath inputSrcs
|
||||
putText platform
|
||||
|
||||
@ -4,14 +4,21 @@
|
||||
|
||||
module Derivation where
|
||||
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.IO.Class ( liftIO )
|
||||
|
||||
import Data.Text (Text)
|
||||
import Nix.Derivation (Derivation(..), DerivationOutput(..))
|
||||
import System.Nix.StorePath (StorePath, storePathToText)
|
||||
import Data.Text ( Text )
|
||||
import Nix.Derivation ( Derivation(..)
|
||||
, DerivationOutput(..)
|
||||
)
|
||||
import System.Nix.StorePath ( StorePath
|
||||
, storePathToText
|
||||
)
|
||||
|
||||
import System.Nix.Store.Remote (MonadStore, addToStore, addTextToStore)
|
||||
import System.Nix.Hash (HashAlgorithm(SHA256))
|
||||
import System.Nix.Store.Remote ( MonadStore
|
||||
, addToStore
|
||||
, addTextToStore
|
||||
)
|
||||
import System.Nix.Hash ( HashAlgorithm(SHA256) )
|
||||
|
||||
import qualified Data.Map
|
||||
import qualified Data.Set
|
||||
@ -24,13 +31,13 @@ import qualified System.Nix.StorePath
|
||||
import qualified System.Directory
|
||||
|
||||
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 ]
|
||||
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 ]
|
||||
, args = Data.Vector.fromList ["-e", storePathToText buildScript]
|
||||
, env = Data.Map.fromList [("testEnv", "true")]
|
||||
}
|
||||
|
||||
@ -41,34 +48,35 @@ withBash action = do
|
||||
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
|
||||
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
|
||||
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
|
||||
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
|
||||
let d = drvSample bash buildScript outputPath
|
||||
|
||||
pth <- addTextToStore
|
||||
"hnix-store-derivation"
|
||||
(Data.Text.Lazy.toStrict
|
||||
pth <- addTextToStore
|
||||
"hnix-store-derivation"
|
||||
( Data.Text.Lazy.toStrict
|
||||
$ Data.Text.Lazy.Builder.toLazyText
|
||||
$ System.Nix.Derivation.buildDerivation d
|
||||
)
|
||||
mempty
|
||||
False
|
||||
)
|
||||
mempty
|
||||
False
|
||||
|
||||
liftIO $ print d
|
||||
action pth d
|
||||
liftIO $ print d
|
||||
action pth d
|
||||
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
import NixDaemon
|
||||
import NixDaemon
|
||||
import qualified Spec
|
||||
|
||||
-- we run remote tests in
|
||||
|
||||
@ -5,23 +5,28 @@
|
||||
|
||||
module NixDaemon where
|
||||
|
||||
import Control.Monad (void)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Exception (bracket)
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Data.Either (isRight, isLeft)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.HashSet as HS
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Bool ( bool )
|
||||
import Control.Monad ( void )
|
||||
import Control.Monad.IO.Class ( liftIO )
|
||||
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
|
||||
import System.Linux.Namespaces as NS
|
||||
import Test.Tasty.Hspec (Spec, describe, context)
|
||||
import qualified Test.Tasty.Hspec as Hspec
|
||||
import qualified System.Process as P
|
||||
import System.Posix.User as U
|
||||
import System.Linux.Namespaces as NS
|
||||
import Test.Tasty.Hspec ( Spec
|
||||
, describe
|
||||
, context
|
||||
)
|
||||
import qualified Test.Tasty.Hspec as Hspec
|
||||
import Test.Hspec.Expectations.Lifted
|
||||
|
||||
import System.FilePath
|
||||
@ -34,39 +39,40 @@ import System.Nix.Store.Remote.Protocol
|
||||
|
||||
import Derivation
|
||||
|
||||
createProcessEnv :: FilePath
|
||||
-> String
|
||||
-> [String]
|
||||
-> IO P.ProcessHandle
|
||||
createProcessEnv :: FilePath -> String -> [String] -> IO P.ProcessHandle
|
||||
createProcessEnv fp proc args = do
|
||||
mPath <- System.Environment.lookupEnv "PATH"
|
||||
mPath <- System.Environment.lookupEnv "PATH"
|
||||
|
||||
(_, _, _, ph) <- P.createProcess (P.proc proc args) { P.cwd = Just $ fp
|
||||
, P.env = Just $ mockedEnv mPath fp }
|
||||
(_, _, _, ph) <-
|
||||
P.createProcess (P.proc proc args)
|
||||
{ P.cwd = Just $ fp
|
||||
, P.env = Just $ mockedEnv mPath fp
|
||||
}
|
||||
return ph
|
||||
|
||||
mockedEnv :: Maybe String -> FilePath -> [(String, FilePath)]
|
||||
mockedEnv mEnvPath fp = map (\(a, b) -> (a, b)) [
|
||||
("NIX_STORE_DIR", fp </> "store")
|
||||
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")
|
||||
, ("NIX_LOG_DIR" , fp </> "var" </> "log")
|
||||
, ("NIX_STATE_DIR" , fp </> "var" </> "nix")
|
||||
, ("NIX_CONF_DIR" , fp </> "etc")
|
||||
-- , ("NIX_REMOTE", "daemon")
|
||||
] ++ (maybe [] (\x -> [("PATH", x)]) mEnvPath)
|
||||
] <> (maybe [] (\x -> [("PATH", x)]) mEnvPath)
|
||||
|
||||
waitSocket :: FilePath -> Int -> IO ()
|
||||
waitSocket _ 0 = fail "No socket"
|
||||
waitSocket fp x = do
|
||||
ex <- doesFileExist fp
|
||||
case ex of
|
||||
True -> return ()
|
||||
False -> threadDelay 100000 >> waitSocket fp (x - 1)
|
||||
bool
|
||||
(threadDelay 100000 >> waitSocket fp (x - 1))
|
||||
(return ())
|
||||
ex
|
||||
|
||||
writeConf :: FilePath -> IO ()
|
||||
writeConf fp = do
|
||||
writeFile fp $ unlines [
|
||||
"build-users-group = "
|
||||
writeConf fp =
|
||||
writeFile fp $ unlines
|
||||
[ "build-users-group = "
|
||||
, "trusted-users = root"
|
||||
, "allowed-users = *"
|
||||
, "fsync-metadata = false"
|
||||
@ -85,14 +91,16 @@ accepted connection from pid 22959, user root (trusted)
|
||||
error: changing ownership of path '/run/user/1000/test-nix-store-06b0d249e5616122/store': Invalid argument
|
||||
-}
|
||||
|
||||
startDaemon :: FilePath -> IO (P.ProcessHandle, MonadStore a -> IO (Either String a, [Logger]))
|
||||
startDaemon
|
||||
:: FilePath
|
||||
-> IO (P.ProcessHandle, MonadStore a -> IO (Either String a, [Logger]))
|
||||
startDaemon fp = do
|
||||
writeConf (fp </> "etc" </> "nix.conf")
|
||||
p <- createProcessEnv fp "nix-daemon" []
|
||||
waitSocket sockFp 30
|
||||
return (p, runStoreOpts sockFp (fp </> "store"))
|
||||
where
|
||||
sockFp = fp </> "var/nix/daemon-socket/socket"
|
||||
where
|
||||
sockFp = fp </> "var/nix/daemon-socket/socket"
|
||||
|
||||
enterNamespaces :: IO ()
|
||||
enterNamespaces = do
|
||||
@ -107,14 +115,13 @@ enterNamespaces = do
|
||||
|
||||
withNixDaemon
|
||||
:: ((MonadStore a -> IO (Either String a, [Logger])) -> IO a) -> IO a
|
||||
withNixDaemon action = do
|
||||
withNixDaemon action =
|
||||
withSystemTempDirectory "test-nix-store" $ \path -> do
|
||||
|
||||
mapM_ (createDirectory . snd)
|
||||
(filter ((/= "NIX_REMOTE") . fst) $ mockedEnv Nothing path)
|
||||
(filter ((/= "NIX_REMOTE") . fst) $ mockedEnv Nothing path)
|
||||
|
||||
ini <- createProcessEnv path
|
||||
"nix-store" ["--init"]
|
||||
ini <- createProcessEnv path "nix-store" ["--init"]
|
||||
void $ P.waitForProcess ini
|
||||
|
||||
writeFile (path </> "dummy") "Hello World"
|
||||
@ -134,7 +141,8 @@ it
|
||||
-> m c
|
||||
-> (a -> Bool)
|
||||
-> Hspec.SpecWith (m () -> IO (a, b))
|
||||
it name action check = Hspec.it name $ \run -> (run (action >> return ())) `checks` check
|
||||
it name action check =
|
||||
Hspec.it name $ \run -> (run (action >> return ())) `checks` check
|
||||
|
||||
itRights
|
||||
:: (Show a, Show b, Show c, Monad m)
|
||||
@ -173,28 +181,28 @@ withBuilder action = do
|
||||
action path
|
||||
|
||||
builderSh :: Text
|
||||
builderSh = T.concat [ "declare -xp", "export > $out" ]
|
||||
builderSh = "declare -xpexport > $out"
|
||||
|
||||
spec_protocol :: Spec
|
||||
spec_protocol = Hspec.around withNixDaemon $ do
|
||||
spec_protocol = Hspec.around withNixDaemon $
|
||||
|
||||
describe "store" $ do
|
||||
|
||||
context "syncWithGC" $ do
|
||||
context "syncWithGC" $
|
||||
itRights "syncs with garbage collector" syncWithGC
|
||||
|
||||
context "verifyStore" $ do
|
||||
itRights "check=False repair=False" $ do
|
||||
itRights "check=False repair=False" $
|
||||
verifyStore False False `shouldReturn` False
|
||||
|
||||
itRights "check=True repair=False" $ do
|
||||
itRights "check=True repair=False" $
|
||||
verifyStore True False `shouldReturn` False
|
||||
|
||||
--privileged
|
||||
itRights "check=True repair=True" $ do
|
||||
itRights "check=True repair=True" $
|
||||
verifyStore True True `shouldReturn` False
|
||||
|
||||
context "addTextToStore" $ do
|
||||
context "addTextToStore" $
|
||||
itRights "adds text to store" $ withPath $ const return ()
|
||||
|
||||
context "isValidPathUncached" $ do
|
||||
@ -205,18 +213,19 @@ spec_protocol = Hspec.around withNixDaemon $ do
|
||||
|
||||
context "queryAllValidPaths" $ do
|
||||
itRights "empty query" $ queryAllValidPaths
|
||||
itRights "non-empty query" $ withPath $ \path -> queryAllValidPaths `shouldReturn` (HS.fromList [path])
|
||||
itRights "non-empty query" $ withPath $ \path ->
|
||||
queryAllValidPaths `shouldReturn` (HS.fromList [path])
|
||||
|
||||
context "queryPathInfoUncached" $ do
|
||||
context "queryPathInfoUncached" $
|
||||
itRights "queries path info" $ withPath $ queryPathInfoUncached
|
||||
|
||||
context "ensurePath" $ do
|
||||
context "ensurePath" $
|
||||
itRights "simple ensure" $ withPath $ ensurePath
|
||||
|
||||
context "addTempRoot" $ do
|
||||
context "addTempRoot" $
|
||||
itRights "simple addition" $ withPath $ addTempRoot
|
||||
|
||||
context "addIndirectRoot" $ do
|
||||
context "addIndirectRoot" $
|
||||
itRights "simple addition" $ withPath $ addIndirectRoot
|
||||
|
||||
context "buildPaths" $ do
|
||||
@ -232,27 +241,25 @@ spec_protocol = Hspec.around withNixDaemon $ do
|
||||
let pathSet = HS.fromList [path]
|
||||
buildPaths pathSet Repair
|
||||
|
||||
context "roots" $ do
|
||||
context "findRoots" $ do
|
||||
context "roots" $ context "findRoots" $ do
|
||||
itRights "empty roots" $ (findRoots `shouldReturn` M.empty)
|
||||
|
||||
itRights "path added as a temp root" $ withPath $ \_ -> do
|
||||
roots <- findRoots
|
||||
roots `shouldSatisfy` ((==1) . M.size)
|
||||
roots `shouldSatisfy` ((== 1) . M.size)
|
||||
|
||||
context "optimiseStore" $ do
|
||||
itRights "optimises" $ optimiseStore
|
||||
context "optimiseStore" $ itRights "optimises" $ optimiseStore
|
||||
|
||||
context "queryMissing" $ do
|
||||
context "queryMissing" $
|
||||
itRights "queries" $ withPath $ \path -> do
|
||||
let pathSet = HS.fromList [path]
|
||||
queryMissing pathSet `shouldReturn` (HS.empty, HS.empty, HS.empty, 0, 0)
|
||||
|
||||
context "addToStore" $ do
|
||||
context "addToStore" $
|
||||
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 fp False (pure True) False
|
||||
liftIO $ print res
|
||||
|
||||
context "with dummy" $ do
|
||||
@ -263,8 +270,8 @@ spec_protocol = Hspec.around withNixDaemon $ do
|
||||
liftIO $ putStrLn $ show path
|
||||
(isValidPathUncached path) `shouldReturn` True
|
||||
|
||||
context "derivation" $ do
|
||||
itRights "build derivation" $ do
|
||||
context "derivation" $
|
||||
itRights "build derivation" $
|
||||
withDerivation $ \path drv -> do
|
||||
result <- buildDerivation path drv Normal
|
||||
result `shouldSatisfy` ((==AlreadyValid) . status)
|
||||
result `shouldSatisfy` ((== AlreadyValid) . status)
|
||||
|
||||
@ -6,9 +6,7 @@ import System.Nix.Store.Remote.Util
|
||||
import Test.Tasty.QuickCheck
|
||||
|
||||
prop_TextToBSLRoundtrip :: Text -> Property
|
||||
prop_TextToBSLRoundtrip x =
|
||||
bslToText (textToBSL x) === x
|
||||
prop_TextToBSLRoundtrip x = bslToText (textToBSL x) === x
|
||||
|
||||
prop_TextToBSRoundtrip :: Text -> Property
|
||||
prop_TextToBSRoundtrip x =
|
||||
bsToText (textToBS x) === x
|
||||
prop_TextToBSRoundtrip x = bsToText (textToBS x) === x
|
||||
|
||||
Loading…
Reference in New Issue
Block a user