Skip to content

Commit 8608606

Browse files
layuslayus
committed
Heavy lifting
This refactors the store to make it composable with arbitrary mtl monad stacks, with the added constraint that `addToStore` takes a filtering fucntion `FilePath -> PathFilter -> m Bool` which is not MonadBaseControl compatible, and cannot be lifted (the monad is in a negative/contravariant position). The solution involves a RemoteStoreT transformer, a MonadRemoteStore monad and still lacks a proper generic MonadStore which I would like to make generic across all the store implementations (in-memeory / read-only / remote daemon / etc.)
1 parent aaba7f5 commit 8608606

File tree

11 files changed

+208
-127
lines changed

11 files changed

+208
-127
lines changed

‎hnix-store-core/src/System/Nix/Internal/Nar/Effects.hs

+13-7
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,7 @@
55

66
module System.Nix.Internal.Nar.Effects
77
( NarEffects(..)
8+
, PathType(..)
89
, narEffectsIO
910
) where
1011

@@ -18,9 +19,16 @@ import Data.Int (Int64)
1819
import qualified System.Directory as Directory
1920
import qualified System.Directory as Directory
2021
import qualified System.IO as IO
21-
import System.Posix.Files (createSymbolicLink, fileSize,
22-
getFileStatus, isDirectory,
23-
readSymbolicLink)
22+
import System.Posix.Files (createSymbolicLink, fileSize, readSymbolicLink,
23+
getFileStatus, isRegularFile, isDirectory, isSymbolicLink)
24+
25+
data PathType = Regular | Directory | Symlink | Unknown deriving Show
26+
27+
pathTypeFromPosix status
28+
| isRegularFile status = Regular
29+
| isDirectory status = Directory
30+
| isSymbolicLink status = Symlink
31+
| otherwise = Unknown
2432

2533
data NarEffects (m :: * -> *) = NarEffects {
2634
narReadFile :: FilePath -> m BSL.ByteString
@@ -31,8 +39,7 @@ data NarEffects (m :: * -> *) = NarEffects {
3139
, narCreateLink :: FilePath -> FilePath -> m ()
3240
, narGetPerms :: FilePath -> m Directory.Permissions
3341
, narSetPerms :: FilePath -> Directory.Permissions -> m ()
34-
, narIsDir :: FilePath -> m Bool
35-
, narIsSymLink :: FilePath -> m Bool
42+
, narPathType :: FilePath -> m PathType
3643
, narFileSize :: FilePath -> m Int64
3744
, narReadLink :: FilePath -> m FilePath
3845
, narDeleteDir :: FilePath -> m ()
@@ -57,8 +64,7 @@ narEffectsIO = NarEffects {
5764
, narCreateLink = \f t -> IO.liftIO $ createSymbolicLink f t
5865
, narGetPerms = IO.liftIO . Directory.getPermissions
5966
, narSetPerms = \f p -> IO.liftIO $ Directory.setPermissions f p
60-
, narIsDir = \d -> fmap isDirectory $ IO.liftIO (getFileStatus d)
61-
, narIsSymLink = IO.liftIO . Directory.pathIsSymbolicLink
67+
, narPathType = \f -> fmap pathTypeFromPosix $ IO.liftIO (getFileStatus f)
6268
, narFileSize = \n -> fmap (fromIntegral . fileSize) $ IO.liftIO (getFileStatus n)
6369
, narReadLink = IO.liftIO . readSymbolicLink
6470
, narDeleteDir = IO.liftIO . Directory.removeDirectoryRecursive

‎hnix-store-core/src/System/Nix/Internal/Nar/Parser.hs

+4-4
Original file line numberDiff line numberDiff line change
@@ -91,10 +91,10 @@ runParser effs (NarParser action) h target = do
9191

9292
cleanup :: m ()
9393
cleanup = do
94-
isDir <- Nar.narIsDir effs target
95-
if isDir
96-
then Nar.narDeleteDir effs target
97-
else Nar.narDeleteFile effs target
94+
pathType <- Nar.narPathType effs target
95+
case pathType of
96+
Nar.Directory -> Nar.narDeleteDir effs target
97+
_ -> Nar.narDeleteFile effs target
9898

9999

100100
instance Trans.MonadTrans NarParser where

‎hnix-store-core/src/System/Nix/Internal/Nar/Streamer.hs

+20-16
Original file line numberDiff line numberDiff line change
@@ -28,26 +28,24 @@ import qualified System.Nix.Internal.Nar.Effects as Nar
2828
streamNarIO
2929
:: forall m.(IO.MonadIO m)
3030
=> (BS.ByteString -> m ())
31+
-> (FilePath -> Nar.PathType -> m Bool)
3132
-> Nar.NarEffects IO
3233
-> FilePath
3334
-> m ()
34-
streamNarIO yield effs basePath = do
35+
streamNarIO yield filter effs basePath = do
3536
yield (str "nix-archive-1")
36-
parens (go basePath)
37+
basePathType <- IO.liftIO $ Nar.narPathType effs basePath
38+
parens (go basePath basePathType)
3739
where
3840

39-
go :: FilePath -> m ()
40-
go path = do
41-
isDir <- IO.liftIO $ Nar.narIsDir effs path
42-
isSymLink <- IO.liftIO $ Nar.narIsSymLink effs path
43-
let isRegular = not (isDir || isSymLink)
44-
45-
when isSymLink $ do
41+
go :: FilePath -> Nar.PathType -> m ()
42+
go path = \case of
43+
Nar.Symlink -> do
4644
target <- IO.liftIO $ Nar.narReadLink effs path
4745
yield $
4846
strs ["type", "symlink", "target", BSC.pack target]
4947

50-
when isRegular $ do
48+
Nar.Regular -> do
5149
isExec <- IO.liftIO $ isExecutable effs path
5250
yield $ strs ["type","regular"]
5351
when (isExec == Executable) (yield $ strs ["executable", ""])
@@ -56,15 +54,21 @@ streamNarIO yield effs basePath = do
5654
yield $ int fSize
5755
yieldFile path fSize
5856

59-
when isDir $ do
57+
Nar.Directory -> do
6058
fs <- IO.liftIO (Nar.narListDir effs path)
6159
yield $ strs ["type", "directory"]
6260
forM_ (List.sort fs) $ \f -> do
63-
yield $ str "entry"
64-
parens $ do
65-
let fullName = path </> f
66-
yield (strs ["name", BSC.pack f, "node"])
67-
parens (go fullName)
61+
let fullName = path </> f
62+
pathType <- IO.liftIO $ Nar.narPathType effs fullName
63+
keep <- filter fullName pathType
64+
when keep $ do
65+
yield $ str "entry"
66+
parens $ do
67+
yield (strs ["name", BSC.pack f, "node"])
68+
parens (go fullName pathType)
69+
70+
Nar.Unknown -> do
71+
IO.liftIO $ fail $ "Cannot serialise path " ++ path
6872

6973
str :: BS.ByteString -> BS.ByteString
7074
str t = let len = BS.length t

‎hnix-store-core/src/System/Nix/Nar.hs

+2-1
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,7 @@ module System.Nix.Nar (
1818
-- * Encoding and Decoding NAR archives
1919
buildNarIO
2020
, unpackNarIO
21+
, Nar.PathType (..)
2122

2223
-- * Experimental
2324
, Nar.parseNar
@@ -67,7 +68,7 @@ buildNarIO
6768
-> IO.Handle
6869
-> IO ()
6970
buildNarIO effs basePath outHandle = do
70-
Nar.streamNarIO (\chunk -> BS.hPut outHandle chunk >> Concurrent.threadDelay 10) effs basePath
71+
Nar.streamNarIO (\chunk -> BS.hPut outHandle chunk >> Concurrent.threadDelay 10) (\p pt -> pure True) effs basePath
7172

7273

7374
-- | Read NAR formatted bytes from the @IO.Handle@ and unpack them into

‎hnix-store-remote/src/System/Nix/Store/Remote.hs

+48-42
Original file line numberDiff line numberDiff line change
@@ -9,8 +9,8 @@
99
{-# LANGUAGE RecordWildCards #-}
1010
module System.Nix.Store.Remote
1111
(
12-
MonadStoreT
13-
, MonadStore
12+
RemoteStoreT
13+
, System.Nix.Nar.PathType (..)
1414
, addToStore
1515
, addTextToStore
1616
, addSignatures
@@ -75,14 +75,14 @@ type CheckSigsFlag = Bool
7575
type SubstituteFlag = Bool
7676

7777
-- | Pack `FilePath` as `Nar` and add it to the store.
78-
addToStore :: forall a m. (ValidAlgo a, NamedAlgo a, MonadIO m)
78+
addToStore :: forall a m. (NamedAlgo a, MonadRemoteStore m, MonadIO m)
7979
=> StorePathName -- ^ Name part of the newly created `StorePath`
8080
-> FilePath -- ^ Local `FilePath` to add
8181
-> Bool -- ^ Add target directory recursively
82-
-> (FilePath -> Bool) -- ^ Path filter function
82+
-> (FilePath -> System.Nix.Nar.PathType -> m Bool) -- ^ Path filter function
8383
-> RepairFlag -- ^ Only used by local store backend
84-
-> MonadStoreT m StorePath
85-
addToStore name pth recursive _pathFilter _repair = do
84+
-> m StorePath
85+
addToStore name pth recursive pathFilter _repair = do
8686

8787
runOpArgsIO AddToStore $ \yield -> do
8888
yield $ Data.ByteString.Lazy.toStrict $ Data.Binary.Put.runPut $ do
@@ -96,20 +96,20 @@ addToStore name pth recursive _pathFilter _repair = do
9696

9797
putText $ System.Nix.Hash.algoName @a
9898

99-
System.Nix.Nar.streamNarIO yield System.Nix.Nar.narEffectsIO pth
99+
System.Nix.Nar.streamNarIO yield pathFilter System.Nix.Nar.narEffectsIO pth
100100

101101
sockGetPath
102102

103103
-- | Add text to store.
104104
--
105105
-- Reference accepts repair but only uses it
106106
-- to throw error in case of remote talking to nix-daemon.
107-
addTextToStore :: (MonadIO m)
107+
addTextToStore :: (MonadIO m, MonadRemoteStore m)
108108
=> Text -- ^ Name of the text
109109
-> Text -- ^ Actual text to add
110110
-> StorePathSet -- ^ Set of `StorePath`s that the added text references
111111
-> RepairFlag -- ^ Repair flag, must be `False` in case of remote backend
112-
-> MonadStoreT m StorePath
112+
-> m StorePath
113113
addTextToStore name text references' repair = do
114114
when repair $ error "repairing is not supported when building through the Nix daemon"
115115
runOpArgs AddTextToStore $ do
@@ -118,40 +118,43 @@ addTextToStore name text references' repair = do
118118
putPaths references'
119119
sockGetPath
120120

121-
addSignatures :: StorePath
121+
addSignatures :: (MonadIO m)
122+
=> StorePath
122123
-> [ByteString]
123-
-> MonadStore ()
124+
-> RemoteStoreT m ()
124125
addSignatures p signatures = do
125126
void $ simpleOpArgs AddSignatures $ do
126127
putPath p
127128
putByteStrings signatures
128129

129-
addIndirectRoot :: StorePath -> MonadStore ()
130+
addIndirectRoot :: (MonadIO m) => StorePath -> RemoteStoreT m ()
130131
addIndirectRoot pn = do
131132
void $ simpleOpArgs AddIndirectRoot $ putPath pn
132133

133134
-- | Add temporary garbage collector root.
134135
--
135136
-- This root is removed as soon as the client exits.
136-
addTempRoot :: StorePath -> MonadStore ()
137+
addTempRoot :: (MonadIO m) => StorePath -> RemoteStoreT m ()
137138
addTempRoot pn = do
138139
void $ simpleOpArgs AddTempRoot $ putPath pn
139140

140141
-- | Build paths if they are an actual derivations.
141142
--
142143
-- If derivation output paths are already valid, do nothing.
143-
buildPaths :: StorePathSet
144+
buildPaths :: (MonadIO m)
145+
=> StorePathSet
144146
-> BuildMode
145-
-> MonadStore ()
147+
-> RemoteStoreT m ()
146148
buildPaths ps bm = do
147149
void $ simpleOpArgs BuildPaths $ do
148150
putPaths ps
149151
putInt $ fromEnum bm
150152

151-
buildDerivation :: StorePath
153+
buildDerivation :: (MonadIO m)
154+
=> StorePath
152155
-> Derivation StorePath Text
153156
-> BuildMode
154-
-> MonadStore BuildResult
157+
-> RemoteStoreT m BuildResult
155158
buildDerivation p drv buildMode = do
156159
runOpArgs BuildDerivation $ do
157160
putPath p
@@ -165,12 +168,12 @@ buildDerivation p drv buildMode = do
165168
res <- getSocketIncremental $ getBuildResult
166169
return res
167170

168-
ensurePath :: StorePath -> MonadStore ()
171+
ensurePath :: (MonadIO m) => StorePath -> RemoteStoreT m ()
169172
ensurePath pn = do
170173
void $ simpleOpArgs EnsurePath $ putPath pn
171174

172175
-- | Find garbage collector roots.
173-
findRoots :: MonadStore (Map ByteString StorePath)
176+
findRoots :: (MonadIO m) => RemoteStoreT m (Map ByteString StorePath)
174177
findRoots = do
175178
runOp FindRoots
176179
sd <- getStoreDir
@@ -182,40 +185,42 @@ findRoots = do
182185
r <- catRights res
183186
return $ Data.Map.Strict.fromList r
184187
where
185-
catRights :: [(a, Either String b)] -> MonadStore [(a, b)]
188+
catRights :: (MonadIO m) => [(a, Either String b)] -> RemoteStoreT m [(a, b)]
186189
catRights = mapM ex
187190

188-
ex :: (a, Either [Char] b) -> MonadStore (a, b)
191+
ex :: (MonadIO m) => (a, Either [Char] b) -> RemoteStoreT m (a, b)
189192
ex (x, Right y) = return (x, y)
190193
ex (_x , Left e) = error $ "Unable to decode root: " ++ e
191194

192-
isValidPathUncached :: StorePath -> MonadStore Bool
195+
isValidPathUncached :: (MonadIO m) => StorePath -> RemoteStoreT m Bool
193196
isValidPathUncached p = do
194197
simpleOpArgs IsValidPath $ putPath p
195198

196199
-- | Query valid paths from set, optionally try to use substitutes.
197-
queryValidPaths :: StorePathSet -- ^ Set of `StorePath`s to query
200+
queryValidPaths :: (MonadIO m)
201+
=> StorePathSet -- ^ Set of `StorePath`s to query
198202
-> SubstituteFlag -- ^ Try substituting missing paths when `True`
199-
-> MonadStore StorePathSet
203+
-> RemoteStoreT m StorePathSet
200204
queryValidPaths ps substitute = do
201205
runOpArgs QueryValidPaths $ do
202206
putPaths ps
203207
putBool substitute
204208
sockGetPaths
205209

206-
queryAllValidPaths :: MonadStore StorePathSet
210+
queryAllValidPaths :: (MonadIO m) => RemoteStoreT m StorePathSet
207211
queryAllValidPaths = do
208212
runOp QueryAllValidPaths
209213
sockGetPaths
210214

211-
querySubstitutablePaths :: StorePathSet -> MonadStore StorePathSet
215+
querySubstitutablePaths :: (MonadIO m) => StorePathSet -> RemoteStoreT m StorePathSet
212216
querySubstitutablePaths ps = do
213217
runOpArgs QuerySubstitutablePaths $ do
214218
putPaths ps
215219
sockGetPaths
216220

217-
queryPathInfoUncached :: StorePath
218-
-> MonadStore StorePathMetadata
221+
queryPathInfoUncached :: (MonadIO m)
222+
=> StorePath
223+
-> RemoteStoreT m StorePathMetadata
219224
queryPathInfoUncached path = do
220225
runOpArgs QueryPathInfo $ do
221226
putPath path
@@ -252,31 +257,31 @@ queryPathInfoUncached path = do
252257

253258
return $ StorePathMetadata {..}
254259

255-
queryReferrers :: StorePath -> MonadStore StorePathSet
260+
queryReferrers :: (MonadIO m) => StorePath -> RemoteStoreT m StorePathSet
256261
queryReferrers p = do
257262
runOpArgs QueryReferrers $ do
258263
putPath p
259264
sockGetPaths
260265

261-
queryValidDerivers :: StorePath -> MonadStore StorePathSet
266+
queryValidDerivers :: (MonadIO m) => StorePath -> RemoteStoreT m StorePathSet
262267
queryValidDerivers p = do
263268
runOpArgs QueryValidDerivers $ do
264269
putPath p
265270
sockGetPaths
266271

267-
queryDerivationOutputs :: StorePath -> MonadStore StorePathSet
272+
queryDerivationOutputs :: (MonadIO m) => StorePath -> RemoteStoreT m StorePathSet
268273
queryDerivationOutputs p = do
269274
runOpArgs QueryDerivationOutputs $
270275
putPath p
271276
sockGetPaths
272277

273-
queryDerivationOutputNames :: StorePath -> MonadStore StorePathSet
278+
queryDerivationOutputNames :: (MonadIO m) => StorePath -> RemoteStoreT m StorePathSet
274279
queryDerivationOutputNames p = do
275280
runOpArgs QueryDerivationOutputNames $
276281
putPath p
277282
sockGetPaths
278283

279-
queryPathFromHashPart :: Digest StorePathHashAlgo -> MonadStore StorePath
284+
queryPathFromHashPart :: (MonadIO m) => Digest StorePathHashAlgo -> RemoteStoreT m StorePath
280285
queryPathFromHashPart storePathHash = do
281286
runOpArgs QueryPathFromHashPart $
282287
putByteStringLen
@@ -285,12 +290,13 @@ queryPathFromHashPart storePathHash = do
285290
$ System.Nix.Hash.encodeBase32 storePathHash
286291
sockGetPath
287292

288-
queryMissing :: StorePathSet
289-
-> MonadStore ( StorePathSet -- Paths that will be built
290-
, StorePathSet -- Paths that have substitutes
291-
, StorePathSet -- Unknown paths
292-
, Integer -- Download size
293-
, Integer) -- Nar size?
293+
queryMissing :: (MonadIO m)
294+
=> StorePathSet
295+
-> RemoteStoreT m ( StorePathSet -- Paths that will be built
296+
, StorePathSet -- Paths that have substitutes
297+
, StorePathSet -- Unknown paths
298+
, Integer -- Download size
299+
, Integer) -- Nar size?
294300
queryMissing ps = do
295301
runOpArgs QueryMissing $ do
296302
putPaths ps
@@ -302,14 +308,14 @@ queryMissing ps = do
302308
narSize' <- sockGetInt
303309
return (willBuild, willSubstitute, unknown, downloadSize', narSize')
304310

305-
optimiseStore :: MonadStore ()
311+
optimiseStore :: (MonadIO m) => RemoteStoreT m ()
306312
optimiseStore = void $ simpleOp OptimiseStore
307313

308-
syncWithGC :: MonadStore ()
314+
syncWithGC :: (MonadIO m) => RemoteStoreT m ()
309315
syncWithGC = void $ simpleOp SyncWithGC
310316

311317
-- returns True on errors
312-
verifyStore :: CheckFlag -> RepairFlag -> MonadStore Bool
318+
verifyStore :: (MonadIO m) => CheckFlag -> RepairFlag -> RemoteStoreT m Bool
313319
verifyStore check repair = simpleOpArgs VerifyStore $ do
314320
putBool check
315321
putBool repair

0 commit comments

Comments
 (0)