mirror of
https://github.com/haskell-nix/hnix-store.git
synced 2024-09-11 18:05:56 +03:00
hnix-store-remote: Remove erroneous path putting/getting.
mkPath's logic was completely wrong (tried to make a PathName out of the entire path, made up a hash based on the whole path rather than parsing base32) and putPath ignored the store directory and the hash part. Much of the code that depended on these functions was actually correct, but ultimately did the wrong thing. We can resurrect those from git once the primitives are correctly implemented.
This commit is contained in:
Shea Levy
parent
13e0724344
commit
df43823868
@ -1,5 +1,5 @@
|
||||
name: hnix-store-remote
|
||||
version: 0.1.0.0
|
||||
version: 0.2.0.0
|
||||
synopsis: Remote hnix store
|
||||
description: Implementation of the nix store using the daemon protocol.
|
||||
homepage: https://github.com/haskell-nix/hnix-store
|
||||
|
||||
@ -7,47 +7,12 @@
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
module System.Nix.Store.Remote (
|
||||
runStore
|
||||
, isValidPathUncached
|
||||
, queryValidPaths
|
||||
, queryAllValidPaths
|
||||
, querySubstitutablePaths
|
||||
, querySubstitutablePathInfos
|
||||
, queryPathInfoUncached
|
||||
, queryReferrers
|
||||
, queryValidDerivers
|
||||
, queryDerivationOutputs
|
||||
, queryDerivationOutputNames
|
||||
, queryPathFromHashPart
|
||||
, addToStore
|
||||
, addTextToStore
|
||||
, buildPaths
|
||||
, ensurePath
|
||||
, addTempRoot
|
||||
, addIndirectRoot
|
||||
, syncWithGC
|
||||
, findRoots
|
||||
, collectGarbage
|
||||
, optimiseStore
|
||||
, verifyStore
|
||||
, addSignatures
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import qualified Data.Binary.Put as B
|
||||
import Data.Maybe
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Proxy (Proxy)
|
||||
import qualified Data.Text.Lazy as T
|
||||
import qualified Data.Text.Lazy.Encoding as T
|
||||
|
||||
import qualified System.Nix.Build as Build
|
||||
import qualified System.Nix.GC as GC
|
||||
import System.Nix.Path
|
||||
import System.Nix.Hash
|
||||
import System.Nix.Nar (localPackNar, putNar, narEffectsIO)
|
||||
import System.Nix.Util
|
||||
|
||||
import System.Nix.Store.Remote.Types
|
||||
import System.Nix.Store.Remote.Protocol
|
||||
@ -55,196 +20,10 @@ import System.Nix.Store.Remote.Util
|
||||
|
||||
type RepairFlag = Bool
|
||||
type CheckFlag = Bool
|
||||
type SubstituteFlag = Bool
|
||||
|
||||
--setOptions :: StoreSetting -> MonadStore ()
|
||||
|
||||
isValidPathUncached :: Path -> MonadStore Bool
|
||||
isValidPathUncached p = simpleOpArgs IsValidPath $ putPath p
|
||||
|
||||
queryValidPaths :: PathSet -> SubstituteFlag -> MonadStore PathSet
|
||||
queryValidPaths ps substitute = do
|
||||
runOpArgs QueryValidPaths $ do
|
||||
putPaths ps
|
||||
putBool substitute
|
||||
sockGetPaths
|
||||
|
||||
queryAllValidPaths :: MonadStore PathSet
|
||||
queryAllValidPaths = do
|
||||
runOp QueryAllValidPaths
|
||||
sockGetPaths
|
||||
|
||||
querySubstitutablePaths :: PathSet -> MonadStore PathSet
|
||||
querySubstitutablePaths ps = do
|
||||
runOpArgs QuerySubstitutablePaths $ do
|
||||
putPaths ps
|
||||
sockGetPaths
|
||||
|
||||
querySubstitutablePathInfos :: PathSet -> MonadStore [SubstitutablePathInfo]
|
||||
querySubstitutablePathInfos ps = do
|
||||
runOpArgs QuerySubstitutablePathInfos $ do
|
||||
putPaths ps
|
||||
|
||||
cnt <- sockGetInt
|
||||
forM (take cnt $ cycle [(0 :: Int)]) $ pure $ do
|
||||
_pth <- sockGetPath
|
||||
drv <- sockGetStr
|
||||
refs <- sockGetPaths
|
||||
dlSize <- sockGetInt
|
||||
narSize' <- sockGetInt
|
||||
return $ SubstitutablePathInfo {
|
||||
deriver = mkPath drv
|
||||
, references = refs
|
||||
, downloadSize = dlSize
|
||||
, narSize = narSize'
|
||||
}
|
||||
|
||||
queryPathInfoUncached :: Path -> MonadStore ValidPathInfo
|
||||
queryPathInfoUncached p = do
|
||||
runOpArgs QueryPathInfo $ do
|
||||
putPath p
|
||||
|
||||
valid <- sockGetBool
|
||||
unless valid $ error "Path is not valid"
|
||||
|
||||
drv <- sockGetStr
|
||||
hash' <- lBSToText <$> sockGetStr
|
||||
refs <- sockGetPaths
|
||||
regTime <- sockGetInt
|
||||
size <- sockGetInt
|
||||
ulti <- sockGetBool
|
||||
sigs' <- map lBSToText <$> sockGetStrings
|
||||
ca' <- lBSToText <$> sockGetStr
|
||||
return $ ValidPathInfo {
|
||||
path = p
|
||||
, deriverVP = mkPath drv
|
||||
, narHash = hash'
|
||||
, referencesVP = refs
|
||||
, registrationTime = regTime
|
||||
, narSizeVP = size
|
||||
, ultimate = ulti
|
||||
, sigs = sigs'
|
||||
, ca = ca'
|
||||
}
|
||||
|
||||
queryReferrers :: Path -> MonadStore PathSet
|
||||
queryReferrers p = do
|
||||
runOpArgs QueryReferrers $ do
|
||||
putPath p
|
||||
sockGetPaths
|
||||
|
||||
queryValidDerivers :: Path -> MonadStore PathSet
|
||||
queryValidDerivers p = do
|
||||
runOpArgs QueryValidDerivers $ do
|
||||
putPath p
|
||||
sockGetPaths
|
||||
|
||||
queryDerivationOutputs :: Path -> MonadStore PathSet
|
||||
queryDerivationOutputs p = do
|
||||
runOpArgs QueryDerivationOutputs $
|
||||
putPath p
|
||||
sockGetPaths
|
||||
|
||||
queryDerivationOutputNames :: Path -> MonadStore PathSet
|
||||
queryDerivationOutputNames p = do
|
||||
runOpArgs QueryDerivationOutputNames $
|
||||
putPath p
|
||||
sockGetPaths
|
||||
|
||||
-- XXX: this is broken as I don't know how to get hashes from paths (fix mkPath)
|
||||
queryPathFromHashPart :: Digest PathHashAlgo -> MonadStore (Maybe Path)
|
||||
queryPathFromHashPart d = do
|
||||
runOpArgs QueryPathFromHashPart $
|
||||
-- TODO: replace `undefined` with digest encoding function when
|
||||
-- [issue 24](https://github.com/haskell-nix/hnix-store/issues/24) is
|
||||
-- closed
|
||||
putByteStringLen $ LBS.fromStrict $ undefined d
|
||||
sockGetPath
|
||||
|
||||
type PathFilter = Path -> Bool
|
||||
|
||||
addToStore
|
||||
:: forall a. (ValidAlgo a, NamedAlgo a)
|
||||
=> LBS.ByteString
|
||||
-> FilePath
|
||||
-> Bool
|
||||
-> Proxy a
|
||||
-> PathFilter
|
||||
-> RepairFlag
|
||||
-> MonadStore Path
|
||||
addToStore name pth recursive algoProxy pfilter repair = do
|
||||
|
||||
-- TODO: Is this lazy enough? We need `B.putLazyByteString bs` to stream `bs`
|
||||
bs :: LBS.ByteString <- liftIO $ B.runPut . putNar <$> localPackNar narEffectsIO pth
|
||||
|
||||
runOpArgs AddToStore $ do
|
||||
putByteStringLen name
|
||||
putInt 1
|
||||
if recursive
|
||||
then putInt 1
|
||||
else putInt 0
|
||||
|
||||
putByteStringLen (T.encodeUtf8 . T.toLower . T.fromStrict $ algoName @a)
|
||||
|
||||
B.putLazyByteString bs
|
||||
|
||||
fmap (fromMaybe $ error "TODO: Error") sockGetPath
|
||||
|
||||
|
||||
addTextToStore :: LBS.ByteString -> LBS.ByteString -> PathSet -> RepairFlag -> MonadStore (Maybe Path)
|
||||
addTextToStore name text references' repair = do
|
||||
runOpArgs AddTextToStore $ do
|
||||
putByteStringLen name
|
||||
putByteStringLen text
|
||||
putPaths references'
|
||||
sockGetPath
|
||||
|
||||
buildPaths :: PathSet -> Build.BuildMode -> MonadStore ()
|
||||
buildPaths ps bm = void $ simpleOpArgs EnsurePath $ do
|
||||
putPaths ps
|
||||
putInt $ fromEnum bm
|
||||
|
||||
ensurePath :: Path -> MonadStore ()
|
||||
ensurePath pn = void $ simpleOpArgs EnsurePath $ putPath pn
|
||||
|
||||
addTempRoot :: Path -> MonadStore ()
|
||||
addTempRoot pn = void $ simpleOpArgs AddTempRoot $ putPath pn
|
||||
|
||||
addIndirectRoot :: Path -> MonadStore ()
|
||||
addIndirectRoot pn = void $ simpleOpArgs AddIndirectRoot $ putPath pn
|
||||
|
||||
syncWithGC :: MonadStore ()
|
||||
syncWithGC = void $ simpleOp SyncWithGC
|
||||
|
||||
findRoots :: MonadStore Roots
|
||||
findRoots = do
|
||||
runOp FindRoots
|
||||
res <- getSocketIncremental (do
|
||||
count <- getInt
|
||||
res <- sequence $ replicate count ((,) <$> getPath <*> getPath)
|
||||
return res
|
||||
)
|
||||
|
||||
return $ M.fromList $ catMaybesTupled res
|
||||
where
|
||||
catMaybesTupled :: [(Maybe a, Maybe b)] -> [(a, b)]
|
||||
catMaybesTupled ls = map (\(Just x, Just y) -> (x, y)) $ filter (\(x,y) -> isJust x && isJust y) ls
|
||||
|
||||
collectGarbage :: GC.Options -> MonadStore GC.Result
|
||||
collectGarbage opts = do
|
||||
runOpArgs CollectGarbage $ do
|
||||
putInt $ fromEnum $ GC.operation opts
|
||||
putPaths $ GC.pathsToDelete opts
|
||||
putBool $ GC.ignoreLiveness opts
|
||||
putInt $ GC.maxFreed opts
|
||||
forM_ [(0 :: Int)..2] $ pure $ putInt (0 :: Int) -- removed options
|
||||
|
||||
paths <- sockGetPaths
|
||||
freed <- sockGetInt
|
||||
_obsolete <- sockGetInt :: MonadStore Int
|
||||
|
||||
return $ GC.Result paths freed
|
||||
|
||||
optimiseStore :: MonadStore ()
|
||||
optimiseStore = void $ simpleOp OptimiseStore
|
||||
|
||||
@ -253,8 +32,3 @@ verifyStore :: CheckFlag -> RepairFlag -> MonadStore Bool
|
||||
verifyStore check repair = simpleOpArgs VerifyStore $ do
|
||||
putBool check
|
||||
putBool repair
|
||||
|
||||
addSignatures :: Path -> [LBS.ByteString] -> MonadStore ()
|
||||
addSignatures p signatures = void $ simpleOpArgs AddSignatures $ do
|
||||
putPath p
|
||||
putByteStrings signatures
|
||||
|
||||
@ -16,7 +16,6 @@ import Network.Socket.ByteString (recv, sendAll)
|
||||
|
||||
import System.Nix.Store.Remote.Types
|
||||
import System.Nix.Hash
|
||||
import System.Nix.Path
|
||||
import System.Nix.Util
|
||||
|
||||
|
||||
@ -44,12 +43,6 @@ sockGet = do
|
||||
soc <- ask
|
||||
liftIO $ Just <$> recv soc 8
|
||||
|
||||
sockGetPath :: MonadStore (Maybe Path)
|
||||
sockGetPath = getSocketIncremental getPath
|
||||
|
||||
sockGetPaths :: MonadStore PathSet
|
||||
sockGetPaths = getSocketIncremental getPaths
|
||||
|
||||
sockGetInt :: Integral a => MonadStore a
|
||||
sockGetInt = getSocketIncremental getInt
|
||||
|
||||
@ -68,36 +61,6 @@ lBSToText = T.pack . BSC.unpack . LBS.toStrict
|
||||
textToLBS :: Text -> LBS.ByteString
|
||||
textToLBS = LBS.fromStrict . BSC.pack . T.unpack
|
||||
|
||||
-- XXX: needs work
|
||||
mkPath :: LBS.ByteString -> Maybe Path
|
||||
mkPath p = case (pathName $ lBSToText p) of
|
||||
-- TODO: replace `undefined` with digest encoding function when
|
||||
-- [issue 24](https://github.com/haskell-nix/hnix-store/issues/24)
|
||||
-- is closed
|
||||
Just x -> Just $ Path (hash $ LBS.toStrict p) x --XXX: hash
|
||||
Nothing -> Nothing
|
||||
|
||||
-- WOOT
|
||||
-- import Data.ByteString.Base32 as Base32
|
||||
--drvP = Path (fromJust $ digestFromByteString $ pls $ Base32.decode $ BSC.take 32 $ BSC.drop (BSC.length "/nix/store/") drv) (fromJust $ pathName $ T.pack $ BSC.unpack drv)
|
||||
--pls (Left _) = error "unable to decode hash"
|
||||
--pls (Right x) = x
|
||||
|
||||
getPath :: Get (Maybe Path)
|
||||
getPath = mkPath <$> getByteStringLen
|
||||
|
||||
getPaths :: Get PathSet
|
||||
getPaths = HashSet.fromList . catMaybes . map mkPath <$> getByteStrings
|
||||
|
||||
putPathName :: PathName -> Put
|
||||
putPathName = putByteStringLen . textToLBS . pathNameContents
|
||||
|
||||
putPath :: Path -> Put
|
||||
putPath (Path _hash name) = putPathName name
|
||||
|
||||
putPaths :: PathSet -> Put
|
||||
putPaths = putByteStrings . HashSet.map (\(Path _hash name) -> textToLBS $ pathNameContents name)
|
||||
|
||||
putBool :: Bool -> Put
|
||||
putBool True = putInt (1 :: Int)
|
||||
putBool False = putInt (0 :: Int)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user