From d51ccedf7437208b50289f436ce1479bd75f289d Mon Sep 17 00:00:00 2001 From: Guillaume Maudoux Date: Fri, 29 Nov 2019 01:32:19 +0100 Subject: [PATCH 1/3] Implement 'addToStore' --- hnix-store-remote/hnix-store-remote.cabal | 31 ++++++++++++ .../src/System/Nix/Store/Remote.hs | 34 ++++++++++++++ hnix-store-remote/tests/Driver.hs | 1 + hnix-store-remote/tests/Operations.hs | 47 +++++++++++++++++++ .../tests/data/add-recursive/a/c | 0 hnix-store-remote/tests/data/add-recursive/b | 0 6 files changed, 113 insertions(+) create mode 100644 hnix-store-remote/tests/Driver.hs create mode 100644 hnix-store-remote/tests/Operations.hs create mode 100644 hnix-store-remote/tests/data/add-recursive/a/c create mode 100644 hnix-store-remote/tests/data/add-recursive/b diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index 780e39b7..dc780623 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -38,3 +38,34 @@ library hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + +test-suite format-tests + ghc-options: -rtsopts -fprof-auto + type: exitcode-stdio-1.0 + main-is: Driver.hs + other-modules: + Operations + hs-source-dirs: + tests + build-depends: + hnix-store-core + , hnix-store-remote + , base + , base64-bytestring + , binary + , bytestring + , containers + , directory + , mtl + , network + , process + , text + , unix + , unordered-containers + , tasty + , tasty-discover + , tasty-hspec + , tasty-hunit + , tasty-quickcheck + , temporary + default-language: Haskell2010 diff --git a/hnix-store-remote/src/System/Nix/Store/Remote.hs b/hnix-store-remote/src/System/Nix/Store/Remote.hs index 0c25cc4e..e6e0b1db 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote.hs @@ -7,19 +7,33 @@ {-# LANGUAGE TypeApplications #-} module System.Nix.Store.Remote ( runStore + , addToStore , syncWithGC , optimiseStore , verifyStore ) where import Control.Monad +import Control.Monad.Except +import Data.Text.Lazy as TL +import Data.Text.Lazy.Encoding as TL + +import System.Nix.Hash +import System.Nix.Nar +import System.Nix.StorePath import System.Nix.Store.Remote.Types import System.Nix.Store.Remote.Protocol import System.Nix.Store.Remote.Util +import System.Nix.Util + +import Data.ByteString.Lazy as LBS + type RepairFlag = Bool type CheckFlag = Bool +type RecursiveFlag = Bool +type PathFilter = FilePath -> Bool syncWithGC :: MonadStore () syncWithGC = void $ simpleOp SyncWithGC @@ -32,3 +46,23 @@ verifyStore :: CheckFlag -> RepairFlag -> MonadStore Bool verifyStore check repair = simpleOpArgs VerifyStore $ do putBool check putBool repair + +addToStore :: forall hashAlgo. (NamedAlgo hashAlgo, ValidAlgo hashAlgo) + => StorePathName + -> FilePath + -> RecursiveFlag + -> PathFilter + -> RepairFlag + -> MonadStore LBS.ByteString +addToStore name srcPath recursive filter repair = do + nar <- liftIO $ localPackNar narEffectsIO srcPath -- TODO actually use filter. + runOpArgs AddToStore $ do + putByteStringLen $ strToN $ unStorePathName name + putBool $ not (recursive && algoName @hashAlgo == "sha256") -- backwards compatibility hack + putBool recursive + putByteStringLen $ strToN (algoName @hashAlgo) + putNar nar + + sockGetStr + where + strToN = TL.encodeUtf8 . TL.fromStrict diff --git a/hnix-store-remote/tests/Driver.hs b/hnix-store-remote/tests/Driver.hs new file mode 100644 index 00000000..70c55f52 --- /dev/null +++ b/hnix-store-remote/tests/Driver.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover #-} diff --git a/hnix-store-remote/tests/Operations.hs b/hnix-store-remote/tests/Operations.hs new file mode 100644 index 00000000..e5c59a91 --- /dev/null +++ b/hnix-store-remote/tests/Operations.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Operations where + +import Control.Monad +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State +import Data.Maybe + +import Data.Proxy +import Data.Text.Encoding ( encodeUtf8 ) +import Data.Text.Lazy as TL +import Data.Text.Lazy.Encoding as TL + +import System.Nix.Hash +import System.Nix.Nar +import System.Nix.StorePath +import System.Nix.Store.Remote +import System.Nix.Store.Remote.Types +import System.Nix.Store.Remote.Protocol +import System.Nix.Store.Remote.Util +import System.Nix.Util + +import Test.Tasty as T +import Test.Tasty.Hspec +import qualified Test.Tasty.HUnit as HU +import Test.Tasty.QuickCheck +import Text.Read (readMaybe) + +spec_addToStore :: Spec +spec_addToStore = do + + describe "addToStore remote operation" $ do + + it "uploads correctly" $ do + let name = fromJust $ makeStorePathName "test-recursive-add" + let srcPath = "./tests/data/add-recursive" + let recursive = True + let filter path = False -- not used anyway. + let repair = False + res <- runStore $ addToStore @'SHA256 name srcPath recursive filter repair + res `shouldBe` (Right "/nix/store/0mbh3xdb9fkqb2i3iwv6hhz7qiicca83-test-recursive-add",[Last]) + diff --git a/hnix-store-remote/tests/data/add-recursive/a/c b/hnix-store-remote/tests/data/add-recursive/a/c new file mode 100644 index 00000000..e69de29b diff --git a/hnix-store-remote/tests/data/add-recursive/b b/hnix-store-remote/tests/data/add-recursive/b new file mode 100644 index 00000000..e69de29b From 7054f4043d4a9c622cc24e960ab6a28ea2670646 Mon Sep 17 00:00:00 2001 From: Guillaume Maudoux Date: Fri, 29 Nov 2019 23:19:50 +0100 Subject: [PATCH 2/3] Refactor according to comments --- .../src/System/Nix/Internal/StorePath.hs | 3 ++ hnix-store-core/src/System/Nix/Nar.hs | 13 +++-- hnix-store-remote/hnix-store-remote.cabal | 1 + .../src/System/Nix/Store/Remote.hs | 50 ++++++++++++++----- .../src/System/Nix/Store/Remote/Logger.hs | 4 +- .../src/System/Nix/Store/Remote/Protocol.hs | 10 ++-- .../src/System/Nix/Store/Remote/Types.hs | 16 ++++-- .../src/System/Nix/Store/Remote/Util.hs | 14 +++--- hnix-store-remote/tests/Operations.hs | 13 +++-- .../tests/data/add-recursive/a/ignore | 0 10 files changed, 86 insertions(+), 38 deletions(-) create mode 100644 hnix-store-remote/tests/data/add-recursive/a/ignore diff --git a/hnix-store-core/src/System/Nix/Internal/StorePath.hs b/hnix-store-core/src/System/Nix/Internal/StorePath.hs index 5a070ecb..48fe8242 100644 --- a/hnix-store-core/src/System/Nix/Internal/StorePath.hs +++ b/hnix-store-core/src/System/Nix/Internal/StorePath.hs @@ -49,6 +49,9 @@ data StorePath (storeDir :: StoreDir) = StorePath storePathName :: !StorePathName } deriving (Eq, Ord) +instance forall storeDir. KnownStoreDir storeDir => Show (StorePath storeDir) where + show = show . storePathToRawFilePath + instance Hashable (StorePath storeDir) where hashWithSalt s (StorePath {..}) = s `hashWithSalt` storePathHash `hashWithSalt` storePathName diff --git a/hnix-store-core/src/System/Nix/Nar.hs b/hnix-store-core/src/System/Nix/Nar.hs index 58d3a87e..07c2869d 100644 --- a/hnix-store-core/src/System/Nix/Nar.hs +++ b/hnix-store-core/src/System/Nix/Nar.hs @@ -15,6 +15,8 @@ module System.Nix.Nar ( , Nar(..) , getNar , localPackNar + , localPackNar' + , FilePathFilter , localUnpackNar , narEffectsIO , putNar @@ -240,10 +242,15 @@ localUnpackNar effs basePath (Nar fso) = localUnpackFSO basePath fso -- | Pack a NAR from a filepath localPackNar :: Monad m => NarEffects m -> FilePath -> m Nar -localPackNar effs basePath = Nar <$> localPackFSO basePath +localPackNar effs basePath = localPackNar' effs basePath (const True) - where +type FilePathFilter = FilePath -> Bool + +-- | Pack a NAR from a filepath, omitting the entries matching `filter` +localPackNar' :: Monad m => NarEffects m -> FilePath -> FilePathFilter -> m Nar +localPackNar' effs basePath pathFilter = Nar <$> localPackFSO basePath + where localPackFSO path' = do fType <- (,) <$> narIsDir effs path' <*> narIsSymLink effs path' case fType of @@ -252,7 +259,7 @@ localPackNar effs basePath = Nar <$> localPackFSO basePath <*> narFileSize effs path' <*> narReadFile effs path' (True , _) -> fmap (Directory . Map.fromList) $ do - fs <- narListDir effs path' + fs <- filter (pathFilter . (path' )) <$> narListDir effs path' forM fs $ \fp -> (FilePathPart (BSC.pack $ fp),) <$> localPackFSO (path' fp) diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index dc780623..875f533f 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -56,6 +56,7 @@ test-suite format-tests , bytestring , containers , directory + , filepath , mtl , network , process diff --git a/hnix-store-remote/src/System/Nix/Store/Remote.hs b/hnix-store-remote/src/System/Nix/Store/Remote.hs index e6e0b1db..6a66fa09 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote.hs @@ -5,6 +5,8 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + module System.Nix.Store.Remote ( runStore , addToStore @@ -13,13 +15,17 @@ module System.Nix.Store.Remote ( , verifyStore ) where +import Prelude as P import Control.Monad import Control.Monad.Except -import Data.Text.Lazy as TL +import Data.Text as T +import Data.Text.Encoding as T +import Data.Text.Lazy as TL import Data.Text.Lazy.Encoding as TL import System.Nix.Hash +import System.Nix.Internal.Hash import System.Nix.Nar import System.Nix.StorePath import System.Nix.Store.Remote.Types @@ -28,41 +34,59 @@ import System.Nix.Store.Remote.Util import System.Nix.Util import Data.ByteString.Lazy as LBS +import Data.ByteString.Char8 as BS type RepairFlag = Bool type CheckFlag = Bool type RecursiveFlag = Bool -type PathFilter = FilePath -> Bool -syncWithGC :: MonadStore () +syncWithGC :: MonadStore s () syncWithGC = void $ simpleOp SyncWithGC -optimiseStore :: MonadStore () +optimiseStore :: MonadStore s () optimiseStore = void $ simpleOp OptimiseStore -- returns True on errors -verifyStore :: CheckFlag -> RepairFlag -> MonadStore Bool +verifyStore :: CheckFlag -> RepairFlag -> MonadStore s Bool verifyStore check repair = simpleOpArgs VerifyStore $ do putBool check putBool repair -addToStore :: forall hashAlgo. (NamedAlgo hashAlgo, ValidAlgo hashAlgo) +addToStore :: forall hashType storeDir. (NamedAlgo hashType, ValidAlgo hashType, KnownStoreDir storeDir) => StorePathName -> FilePath -> RecursiveFlag - -> PathFilter + -> FilePathFilter -> RepairFlag - -> MonadStore LBS.ByteString -addToStore name srcPath recursive filter repair = do - nar <- liftIO $ localPackNar narEffectsIO srcPath -- TODO actually use filter. + -> MonadStore storeDir (StorePath storeDir) +addToStore name srcPath recursive pathFilter repair = do + when repair $ throwError "addToStore: Cannot repair when using a daemon." + nar <- liftIO $ localPackNar' narEffectsIO srcPath pathFilter runOpArgs AddToStore $ do putByteStringLen $ strToN $ unStorePathName name - putBool $ not (recursive && algoName @hashAlgo == "sha256") -- backwards compatibility hack + putBool $ not (recursive && algoName @hashType == "sha256") -- backward compatibility hack putBool recursive - putByteStringLen $ strToN (algoName @hashAlgo) + putByteStringLen $ strToN (algoName @hashType) putNar nar - sockGetStr + path <- LBS.toStrict <$> sockGetStr + case makeStorePath path of + Just storePath -> return storePath + Nothing -> throwError $ "Path '" ++ (show path) ++ "' is not a valid store path in this store" + where strToN = TL.encodeUtf8 . TL.fromStrict + + makeStorePath :: BS.ByteString -> Maybe (StorePath storeDir) + makeStorePath path = BS.stripPrefix (storeDirVal @storeDir <> "/") path >>= \basename -> + if '/' `BS.elem` basename + then Nothing + else let (drvHash, drvName) = BS.break (== '-') basename in + if BS.length drvHash /= 32 || BS.length drvName <= 1 + then Nothing + else StorePath (Digest drvHash) <$> (makeStorePathName $ T.tail $ T.decodeUtf8 $ drvName) + + + + diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs index 36648453..bc9848a0 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs @@ -26,10 +26,10 @@ controlParser = do 0x52534c54 -> Result <$> getInt <*> getInt <*> getFields x -> fail $ "Invalid control message received:" ++ show x -processOutput :: MonadStore [Logger] +processOutput :: MonadStore s [Logger] processOutput = go decoder where decoder = runGetIncremental controlParser - go :: Decoder Logger -> MonadStore [Logger] + go :: Decoder Logger -> MonadStore s [Logger] go (Done _leftover _consumed ctrl) = do case ctrl of e@(Error _ _) -> return [e] diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Protocol.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Protocol.hs index e0e724cd..0a6a6a3e 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Protocol.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Protocol.hs @@ -107,11 +107,11 @@ opNum AddToStoreNar = 39 opNum QueryMissing = 40 -simpleOp :: WorkerOp -> MonadStore Bool +simpleOp :: WorkerOp -> MonadStore s Bool simpleOp op = do simpleOpArgs op $ return () -simpleOpArgs :: WorkerOp -> Put -> MonadStore Bool +simpleOpArgs :: WorkerOp -> Put -> MonadStore s Bool simpleOpArgs op args = do runOpArgs op args err <- gotError @@ -122,10 +122,10 @@ simpleOpArgs op args = do False -> do sockGetBool -runOp :: WorkerOp -> MonadStore () +runOp :: WorkerOp -> MonadStore s () runOp op = runOpArgs op $ return () -runOpArgs :: WorkerOp -> Put -> MonadStore () +runOpArgs :: WorkerOp -> Put -> MonadStore s () runOpArgs op args = do -- Temporary hack for printing the messages destined for nix-daemon socket @@ -145,7 +145,7 @@ runOpArgs op args = do Error _num msg <- head <$> getError throwError $ BSC.unpack $ LBS.toStrict msg -runStore :: MonadStore a -> IO (Either String a, [Logger]) +runStore :: MonadStore s a -> IO (Either String a, [Logger]) runStore code = do bracket (open sockPath) close run where diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs index eb2520cd..61e22262 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} + module System.Nix.Store.Remote.Types ( MonadStore , Logger(..) @@ -8,13 +12,15 @@ module System.Nix.Store.Remote.Types ( , getError) where +import System.Nix.Internal.StorePath import qualified Data.ByteString.Lazy as LBS import Network.Socket (Socket) import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State -type MonadStore a = ExceptT String (StateT [Logger] (ReaderT Socket IO)) a +type MonadStore (storeDir :: StoreDir) a = ExceptT String (StateT [Logger] (ReaderT Socket IO)) a +-- type AMonadStore s a = forall storeDir. MonadStore storeDir a type ActivityID = Int type ActivityParentID = Int @@ -40,14 +46,14 @@ isError :: Logger -> Bool isError (Error _ _) = True isError _ = False -gotError :: MonadStore Bool +gotError :: MonadStore s Bool gotError = any isError <$> get -getError :: MonadStore [Logger] +getError :: MonadStore s [Logger] getError = filter isError <$> get -getLog :: MonadStore [Logger] +getLog :: MonadStore s [Logger] getLog = get -flushLog :: MonadStore () +flushLog :: MonadStore s () flushLog = put [] diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Util.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Util.hs index 9717dc20..d6be4bf3 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Util.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Util.hs @@ -30,29 +30,29 @@ genericIncremental getsome parser = go decoder go (Fail _leftover _consumed msg) = do error msg -getSocketIncremental :: Get a -> MonadStore a +getSocketIncremental :: Get a -> MonadStore s a getSocketIncremental = genericIncremental sockGet -sockPut :: Put -> MonadStore () +sockPut :: Put -> MonadStore s () sockPut p = do soc <- ask liftIO $ sendAll soc $ LBS.toStrict $ runPut p -sockGet :: MonadStore (Maybe BSC.ByteString) +sockGet :: MonadStore s (Maybe BSC.ByteString) sockGet = do soc <- ask liftIO $ Just <$> recv soc 8 -sockGetInt :: Integral a => MonadStore a +sockGetInt :: Integral a => MonadStore s a sockGetInt = getSocketIncremental getInt -sockGetBool :: MonadStore Bool +sockGetBool :: MonadStore s Bool sockGetBool = (== (1 :: Int)) <$> sockGetInt -sockGetStr :: MonadStore LBS.ByteString +sockGetStr :: MonadStore s LBS.ByteString sockGetStr = getSocketIncremental getByteStringLen -sockGetStrings :: MonadStore [LBS.ByteString] +sockGetStrings :: MonadStore s [LBS.ByteString] sockGetStrings = getSocketIncremental getByteStrings lBSToText :: LBS.ByteString -> Text diff --git a/hnix-store-remote/tests/Operations.hs b/hnix-store-remote/tests/Operations.hs index e5c59a91..aa105a77 100644 --- a/hnix-store-remote/tests/Operations.hs +++ b/hnix-store-remote/tests/Operations.hs @@ -13,10 +13,15 @@ import Data.Maybe import Data.Proxy import Data.Text.Encoding ( encodeUtf8 ) +import Data.Text as T +import Data.Text.Encoding as T import Data.Text.Lazy as TL import Data.Text.Lazy.Encoding as TL +import Data.ByteString.Char8 as BS +import System.FilePath import System.Nix.Hash +import System.Nix.Internal.Hash import System.Nix.Nar import System.Nix.StorePath import System.Nix.Store.Remote @@ -40,8 +45,10 @@ spec_addToStore = do let name = fromJust $ makeStorePathName "test-recursive-add" let srcPath = "./tests/data/add-recursive" let recursive = True - let filter path = False -- not used anyway. + let filter :: FilePathFilter + filter path | takeBaseName path == "ignore" = False + | otherwise = True let repair = False - res <- runStore $ addToStore @'SHA256 name srcPath recursive filter repair - res `shouldBe` (Right "/nix/store/0mbh3xdb9fkqb2i3iwv6hhz7qiicca83-test-recursive-add",[Last]) + res <- runStore $ (addToStore @'SHA256 name srcPath recursive filter repair :: MonadStore "/nix/store" (StorePath "/nix/store")) + res `shouldBe` (Right (StorePath (Digest $ T.encodeUtf8 "0mbh3xdb9fkqb2i3iwv6hhz7qiicca83") name),[Last]) diff --git a/hnix-store-remote/tests/data/add-recursive/a/ignore b/hnix-store-remote/tests/data/add-recursive/a/ignore new file mode 100644 index 00000000..e69de29b From 501099ab667e5dd94b965626651310f60b6ce6d2 Mon Sep 17 00:00:00 2001 From: Guillaume Maudoux Date: Wed, 8 Jan 2020 10:17:21 +0100 Subject: [PATCH 3/3] stash stalled development --- hnix-store-core/src/System/Nix/Hash.hs | 1 + .../src/System/Nix/Internal/Hash.hs | 10 ++- .../src/System/Nix/ReadonlyStore.hs | 49 +++++++++++++- .../src/System/Nix/Store/Remote.hs | 65 ++++++++++++++----- hnix-store-remote/tests/Operations.hs | 2 + 5 files changed, 109 insertions(+), 18 deletions(-) diff --git a/hnix-store-core/src/System/Nix/Hash.hs b/hnix-store-core/src/System/Nix/Hash.hs index 93619674..6909e0eb 100644 --- a/hnix-store-core/src/System/Nix/Hash.hs +++ b/hnix-store-core/src/System/Nix/Hash.hs @@ -10,6 +10,7 @@ module System.Nix.Hash ( , HNix.SomeNamedDigest(..) , HNix.hash , HNix.hashLazy + , HNix.mkDigest , HNix.encodeBase32 , HNix.encodeBase16 diff --git a/hnix-store-core/src/System/Nix/Internal/Hash.hs b/hnix-store-core/src/System/Nix/Internal/Hash.hs index e0b93c23..9a52aa40 100644 --- a/hnix-store-core/src/System/Nix/Internal/Hash.hs +++ b/hnix-store-core/src/System/Nix/Internal/Hash.hs @@ -21,7 +21,7 @@ import qualified Data.ByteString.Base16 as Base16 import Data.Bits (xor) import qualified Data.ByteString.Lazy as BSL import qualified Data.Hashable as DataHashable -import Data.List (foldl') +import Data.List (foldl', find) import Data.Proxy (Proxy(Proxy)) import Data.Text (Text) import qualified Data.Text as T @@ -76,6 +76,14 @@ instance NamedAlgo 'SHA256 where -- | A digest whose 'NamedAlgo' is not known at compile time. data SomeNamedDigest = forall a . NamedAlgo a => SomeDigest (Digest a) +-- | Build a valid named digest from its name +mkDigest :: Text -> BS.ByteString -> Maybe SomeNamedDigest +mkDigest "sha1" = Just . SomeDigest . Digest @'SHA1 +mkDigest "sha256" = Just . SomeDigest . Digest @'SHA256 +mkDigest "md5" = Just . SomeDigest . Digest @'MD5 +mkDigest _ = const Nothing + + -- | Hash an entire (strict) 'BS.ByteString' as a single call. -- -- For example: diff --git a/hnix-store-core/src/System/Nix/ReadonlyStore.hs b/hnix-store-core/src/System/Nix/ReadonlyStore.hs index e6581dbf..551015c9 100644 --- a/hnix-store-core/src/System/Nix/ReadonlyStore.hs +++ b/hnix-store-core/src/System/Nix/ReadonlyStore.hs @@ -7,10 +7,20 @@ module System.Nix.ReadonlyStore where import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.HashSet as HS +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T import Data.Text.Encoding import System.Nix.Hash import System.Nix.StorePath +makeOutputPath :: forall storeDir hashAlgo . (KnownStoreDir storeDir, NamedAlgo hashAlgo) => Text -> Digest hashAlgo -> StorePathName -> Maybe (StorePath storeDir) +makeOutputPath id h nm = makeStorePath ty h <$> name + where + ty = BS.intercalate ":" ["output", encodeUtf8 id] + name = if id == "out" then Just nm else + makeStorePathName $ T.concat [unStorePathName nm, "-", id] + makeStorePath :: forall storeDir hashAlgo . (KnownStoreDir storeDir, NamedAlgo hashAlgo) => ByteString -> Digest hashAlgo -> StorePathName -> StorePath storeDir makeStorePath ty h nm = StorePath storeHash nm where @@ -23,10 +33,45 @@ makeStorePath ty h nm = StorePath storeHash nm ] storeHash = hash s +makeType :: (KnownStoreDir storeDir) => ByteString -> StorePathSet storeDir -> ByteString +makeType name refs = BS.intercalate ":" (name : map storePathToRawFilePath (HS.toList refs)) + makeTextPath :: (KnownStoreDir storeDir) => StorePathName -> Digest 'SHA256 -> StorePathSet storeDir -> StorePath storeDir -makeTextPath nm h refs = makeStorePath ty h nm +makeTextPath nm h refs = makeStorePath (makeType "text" refs) h nm + +makeFixedOutputPath :: forall hashType storeDir. (KnownStoreDir storeDir, NamedAlgo hashType, ValidAlgo hashType) + => Bool -> Digest hashType -> StorePathName -> StorePathSet storeDir -> StorePath storeDir +makeFixedOutputPath recursive digest name refs = + if recursive && algoName @hashType == "sha256" + then makeStorePath (makeType "source" refs) digest name + else if HS.null refs + then makeStorePath "output:out" fixedDigest name + else error "Old style fixed output path cannot have references" where - ty = BS.intercalate ":" ("text" : map storePathToRawFilePath (HS.toList refs)) + fixedDigest = hash @'SHA256 $ BS.concat + [ "fixed:out:" + , (if recursive then "r:" else "") + , encodeUtf8 (encodeBase16 digest) + , ":" + ] computeStorePathForText :: (KnownStoreDir storeDir) => StorePathName -> ByteString -> StorePathSet storeDir -> StorePath storeDir computeStorePathForText nm s refs = makeTextPath nm (hash s) refs + +data DerivationOutput storeDir = DerivationOutput + { path :: StorePath storeDir + , drvHash :: Text + , hashAlgo :: HashAlgorithm + } + +data Derivation storeDir = Derivation + { name :: StorePathName + , outputs :: M.Map Text (StorePath storeDir) + , inputSrcs :: HS.HashSet (StorePath storeDir) + , inputDrvs :: M.Map (StorePath storeDir) [Text] + , platform :: Text + , builder :: Text -- should be typed as a store path + , args :: [ Text ] + , env :: M.Map Text Text + } + diff --git a/hnix-store-remote/src/System/Nix/Store/Remote.hs b/hnix-store-remote/src/System/Nix/Store/Remote.hs index 6a66fa09..2342f539 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote.hs @@ -10,15 +10,21 @@ module System.Nix.Store.Remote ( runStore , addToStore + , addToStore' + , addTextToStore , syncWithGC , optimiseStore , verifyStore + , RecursiveFlag + , RepairFlag + , CheckFlag ) where import Prelude as P import Control.Monad import Control.Monad.Except +import Data.Foldable ( toList ) import Data.Text as T import Data.Text.Encoding as T import Data.Text.Lazy as TL @@ -60,9 +66,18 @@ addToStore :: forall hashType storeDir. (NamedAlgo hashType, ValidAlgo hashType, -> FilePathFilter -> RepairFlag -> MonadStore storeDir (StorePath storeDir) -addToStore name srcPath recursive pathFilter repair = do +addToStore name srcPath recursive pathFilter repair = + addToStore' @hashType @storeDir name (localPackNar' narEffectsIO srcPath pathFilter) recursive repair + +addToStore' :: forall hashType storeDir. (NamedAlgo hashType, ValidAlgo hashType, KnownStoreDir storeDir) + => StorePathName + -> IO Nar + -> RecursiveFlag + -> RepairFlag + -> MonadStore storeDir (StorePath storeDir) +addToStore' name narAction recursive repair = do when repair $ throwError "addToStore: Cannot repair when using a daemon." - nar <- liftIO $ localPackNar' narEffectsIO srcPath pathFilter + nar <- liftIO narAction runOpArgs AddToStore $ do putByteStringLen $ strToN $ unStorePathName name putBool $ not (recursive && algoName @hashType == "sha256") -- backward compatibility hack @@ -70,22 +85,42 @@ addToStore name srcPath recursive pathFilter repair = do putByteStringLen $ strToN (algoName @hashType) putNar nar + getStorePath + + +makeStorePath :: forall storeDir. KnownStoreDir storeDir => BS.ByteString -> Maybe (StorePath storeDir) +makeStorePath path = BS.stripPrefix (storeDirVal @storeDir <> "/") path >>= \basename -> + if '/' `BS.elem` basename + then Nothing + else let (drvHash, drvName) = BS.break (== '-') basename in + if BS.length drvHash /= 32 || BS.length drvName <= 1 + then Nothing + else StorePath (Digest drvHash) <$> (makeStorePathName $ T.tail $ T.decodeUtf8 $ drvName) + +getStorePath :: forall storeDir. KnownStoreDir storeDir => MonadStore storeDir (StorePath storeDir) +getStorePath = do path <- LBS.toStrict <$> sockGetStr case makeStorePath path of Just storePath -> return storePath - Nothing -> throwError $ "Path '" ++ (show path) ++ "' is not a valid store path in this store" - - where - strToN = TL.encodeUtf8 . TL.fromStrict - - makeStorePath :: BS.ByteString -> Maybe (StorePath storeDir) - makeStorePath path = BS.stripPrefix (storeDirVal @storeDir <> "/") path >>= \basename -> - if '/' `BS.elem` basename - then Nothing - else let (drvHash, drvName) = BS.break (== '-') basename in - if BS.length drvHash /= 32 || BS.length drvName <= 1 - then Nothing - else StorePath (Digest drvHash) <$> (makeStorePathName $ T.tail $ T.decodeUtf8 $ drvName) + Nothing -> throwError $ "Path '" ++ show path ++ "' is not a valid store path in this store" + +strToN :: T.Text -> LBS.ByteString +strToN = TL.encodeUtf8 . TL.fromStrict + +addTextToStore :: forall hashType storeDir. (NamedAlgo hashType, ValidAlgo hashType, KnownStoreDir storeDir) + => StorePathName + -> TL.Text + -> StorePathSet storeDir + -> RepairFlag + -> MonadStore storeDir (StorePath storeDir) +addTextToStore name text references repair = do + when repair $ throwError "addTextToStore: Cannot repair when using a daemon." + runOpArgs AddTextToStore $ do + putByteStringLen $ strToN $ unStorePathName name + putByteStringLen $ TL.encodeUtf8 text + putByteStrings $ P.map (LBS.fromStrict . storePathToRawFilePath) $ toList references + + getStorePath diff --git a/hnix-store-remote/tests/Operations.hs b/hnix-store-remote/tests/Operations.hs index aa105a77..91f07695 100644 --- a/hnix-store-remote/tests/Operations.hs +++ b/hnix-store-remote/tests/Operations.hs @@ -51,4 +51,6 @@ spec_addToStore = do let repair = False res <- runStore $ (addToStore @'SHA256 name srcPath recursive filter repair :: MonadStore "/nix/store" (StorePath "/nix/store")) res `shouldBe` (Right (StorePath (Digest $ T.encodeUtf8 "0mbh3xdb9fkqb2i3iwv6hhz7qiicca83") name),[Last]) + -- FIXME this is not the right way to make a nix path due to the encoding being performed twice. + -- It gives something like /nix/store/0ybsdrp66r3nddm7jwkkg9wkcrknd0q70f32f9vp6y3qcin3fwrm-test-recursive-add