1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
|
{- A "remote" that is just a filesystem directory.
-
- Copyright 2011-2017 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Remote.Directory (
remote,
finalizeStoreGeneric,
removeDirGeneric,
) where
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M
import Data.Default
import Annex.Common
import Types.Remote
import Types.Creds
import qualified Git
import Config.Cost
import Config
import Utility.FileMode
import Remote.Helper.Special
import qualified Remote.Directory.LegacyChunked as Legacy
import Annex.Content
import Annex.UUID
import Utility.Metered
remote :: RemoteType
remote = RemoteType {
typename = "directory",
enumerate = const (findSpecialRemotes "directory"),
generate = gen,
setup = directorySetup
}
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
gen r u c gc = do
cst <- remoteCost gc cheapRemoteCost
let chunkconfig = getChunkConfig c
return $ Just $ specialRemote c
(prepareStore dir chunkconfig)
(retrieve dir chunkconfig)
(simplyPrepare $ remove dir)
(simplyPrepare $ checkKey dir chunkconfig)
Remote
{ uuid = u
, cost = cst
, name = Git.repoDescribe r
, storeKey = storeKeyDummy
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap dir chunkconfig
, removeKey = removeKeyDummy
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = True
, storeExport = Just $ storeExportDirectory dir
, retrieveExport = Just $ retrieveExportDirectory dir
, removeExport = Just $ removeExportDirectory dir
, checkPresentExport = Just $ checkPresentExportDirectory dir
, renameExport = Just $ renameExportDirectory dir
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
, config = c
, repo = r
, gitconfig = gc
, localpath = Just dir
, readonly = False
, availability = LocallyAvailable
, remotetype = remote
, mkUnavailable = gen r u c $
gc { remoteAnnexDirectory = Just "/dev/null" }
, getInfo = return [("directory", dir)]
, claimUrl = Nothing
, checkUrl = Nothing
}
where
dir = fromMaybe (giveup "missing directory") $ remoteAnnexDirectory gc
directorySetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
directorySetup _ mu _ c gc = do
u <- maybe (liftIO genUUID) return mu
-- verify configuration is sane
let dir = fromMaybe (giveup "Specify directory=") $
M.lookup "directory" c
absdir <- liftIO $ absPath dir
liftIO $ unlessM (doesDirectoryExist absdir) $
giveup $ "Directory does not exist: " ++ absdir
(c', _encsetup) <- encryptionSetup c gc
-- The directory is stored in git config, not in this remote's
-- persistant state, so it can vary between hosts.
gitConfigSpecialRemote u c' "directory" absdir
return (M.delete "directory" c', u)
{- Locations to try to access a given Key in the directory.
- We try more than one since we used to write to different hash
- directories. -}
locations :: FilePath -> Key -> [FilePath]
locations d k = map (d </>) (keyPaths k)
{- Returns the location off a Key in the directory. If the key is
- present, returns the location that is actually used, otherwise
- returns the first, default location. -}
getLocation :: FilePath -> Key -> IO FilePath
getLocation d k = do
let locs = locations d k
fromMaybe (Prelude.head locs) <$> firstM doesFileExist locs
{- Directory where the file(s) for a key are stored. -}
storeDir :: FilePath -> Key -> FilePath
storeDir d k = addTrailingPathSeparator $ d </> hashDirLower def k </> keyFile k
{- Where we store temporary data for a key, in the directory, as it's being
- written. -}
tmpDir :: FilePath -> Key -> FilePath
tmpDir d k = addTrailingPathSeparator $ d </> "tmp" </> keyFile k
{- Check if there is enough free disk space in the remote's directory to
- store the key. Note that the unencrypted key size is checked. -}
prepareStore :: FilePath -> ChunkConfig -> Preparer Storer
prepareStore d chunkconfig = checkPrepare (checkDiskSpaceDirectory d)
(byteStorer $ store d chunkconfig)
where
checkDiskSpaceDirectory :: FilePath -> Key -> Annex Bool
checkDiskSpaceDirectory d k = do
annexdir <- fromRepo gitAnnexObjectDir
samefilesystem <- liftIO $ catchDefaultIO False $
(\a b -> deviceID a == deviceID b)
<$> getFileStatus d
<*> getFileStatus annexdir
checkDiskSpace (Just d) k 0 samefilesystem
store :: FilePath -> ChunkConfig -> Key -> L.ByteString -> MeterUpdate -> Annex Bool
store d chunkconfig k b p = liftIO $ do
void $ tryIO $ createDirectoryIfMissing True tmpdir
case chunkconfig of
LegacyChunks chunksize -> Legacy.store chunksize finalizeStoreGeneric k b p tmpdir destdir
_ -> do
let tmpf = tmpdir </> keyFile k
meteredWriteFile p tmpf b
finalizeStoreGeneric tmpdir destdir
return True
where
tmpdir = tmpDir d k
destdir = storeDir d k
{- Passed a temp directory that contains the files that should be placed
- in the dest directory, moves it into place. Anything already existing
- in the dest directory will be deleted. File permissions will be locked
- down. -}
finalizeStoreGeneric :: FilePath -> FilePath -> IO ()
finalizeStoreGeneric tmp dest = do
void $ tryIO $ allowWrite dest -- may already exist
void $ tryIO $ removeDirectoryRecursive dest -- or not exist
createDirectoryIfMissing True (parentDir dest)
renameDirectory tmp dest
-- may fail on some filesystems
void $ tryIO $ do
mapM_ preventWrite =<< dirContents dest
preventWrite dest
retrieve :: FilePath -> ChunkConfig -> Preparer Retriever
retrieve d (LegacyChunks _) = Legacy.retrieve locations d
retrieve d _ = simplyPrepare $ byteRetriever $ \k sink ->
sink =<< liftIO (L.readFile =<< getLocation d k)
retrieveCheap :: FilePath -> ChunkConfig -> Key -> AssociatedFile -> FilePath -> Annex Bool
-- no cheap retrieval possible for chunks
retrieveCheap _ (UnpaddedChunks _) _ _ _ = return False
retrieveCheap _ (LegacyChunks _) _ _ _ = return False
#ifndef mingw32_HOST_OS
retrieveCheap d NoChunks k _af f = liftIO $ catchBoolIO $ do
file <- absPath =<< getLocation d k
ifM (doesFileExist file)
( do
createSymbolicLink file f
return True
, return False
)
#else
retrieveCheap _ _ _ _ _ = return False
#endif
remove :: FilePath -> Remover
remove d k = liftIO $ removeDirGeneric d (storeDir d k)
{- Removes the directory, which must be located under the topdir.
-
- Succeeds even on directories and contents that do not have write
- permission.
-
- If the directory does not exist, succeeds as long as the topdir does
- exist. If the topdir does not exist, fails, because in this case the
- remote is not currently accessible and probably still has the content
- we were supposed to remove from it.
-}
removeDirGeneric :: FilePath -> FilePath -> IO Bool
removeDirGeneric topdir dir = do
void $ tryIO $ allowWrite dir
#ifdef mingw32_HOST_OS
{- Windows needs the files inside the directory to be writable
- before it can delete them. -}
void $ tryIO $ mapM_ allowWrite =<< dirContents dir
#endif
ok <- catchBoolIO $ do
removeDirectoryRecursive dir
return True
if ok
then return ok
else doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir)
checkKey :: FilePath -> ChunkConfig -> CheckPresent
checkKey d (LegacyChunks _) k = Legacy.checkKey d locations k
checkKey d _ k = checkPresentGeneric d (locations d k)
checkPresentGeneric :: FilePath -> [FilePath] -> Annex Bool
checkPresentGeneric d ps = liftIO $
ifM (anyM doesFileExist ps)
( return True
, ifM (doesDirectoryExist d)
( return False
, giveup $ "directory " ++ d ++ " is not accessible"
)
)
exportPath :: FilePath -> ExportLocation -> FilePath
exportPath d (ExportLocation loc) = d </> loc
storeExportDirectory :: FilePath -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
storeExportDirectory d src _k loc p = liftIO $ catchBoolIO $ do
createDirectoryIfMissing True dest
withMeteredFile src p (L.writeFile dest)
return True
where
dest = exportPath d loc
retrieveExportDirectory :: FilePath -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex (Bool, Verification)
retrieveExportDirectory d _k loc dest p = unVerified $ liftIO $ catchBoolIO $ do
withMeteredFile src p (L.writeFile dest)
return True
where
src = exportPath d loc
removeExportDirectory :: FilePath -> Key -> ExportLocation -> Annex Bool
removeExportDirectory d _k loc = liftIO $ do
nukeFile src
void $ tryIO $ removeDirectory $ takeDirectory src
return True
where
src = exportPath d loc
checkPresentExportDirectory :: FilePath -> Key -> ExportLocation -> Annex Bool
checkPresentExportDirectory d _k loc =
checkPresentGeneric d [exportPath d loc]
renameExportDirectory :: FilePath -> Key -> ExportLocation -> ExportLocation -> Annex Bool
renameExportDirectory d _k oldloc newloc = liftIO $ catchBoolIO $ do
createDirectoryIfMissing True dest
renameFile src dest
void $ tryIO $ removeDirectory $ takeDirectory src
return True
where
src = exportPath d oldloc
dest = exportPath d newloc
|