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
|
{- exports to remotes
-
- Copyright 2017 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE FlexibleInstances #-}
module Remote.Helper.Export where
import Annex.Common
import Types.Remote
import Types.Backend
import Types.Export
import Types.Key
import Backend
import Remote.Helper.Encryptable (isEncrypted)
import Database.Export
import qualified Data.Map as M
-- | Use for remotes that do not support exports.
class HasExportUnsupported a where
exportUnsupported :: a
instance HasExportUnsupported (RemoteConfig -> RemoteGitConfig -> Annex Bool) where
exportUnsupported = \_ _ -> return False
instance HasExportUnsupported (Annex (ExportActions Annex)) where
exportUnsupported = return $ ExportActions
{ storeExport = \_ _ _ _ -> do
warning "store export is unsupported"
return False
, retrieveExport = \_ _ _ _ -> return False
, checkPresentExport = \_ _ -> return False
, removeExport = \_ _ -> return False
, removeExportDirectory = Just $ \_ -> return False
, renameExport = \_ _ _ -> return False
}
exportTree :: RemoteConfig -> Bool
exportTree c = case M.lookup "exporttree" c of
Just "yes" -> True
_ -> False
exportIsSupported :: RemoteConfig -> RemoteGitConfig -> Annex Bool
exportIsSupported = \_ _ -> return True
-- | Prevent or allow exporttree=yes when setting up a new remote,
-- depending on exportSupported and other configuration.
adjustExportableRemoteType :: RemoteType -> RemoteType
adjustExportableRemoteType rt = rt { setup = setup' }
where
setup' st mu cp c gc = do
let cont = setup rt st mu cp c gc
ifM (exportSupported rt c gc)
( case st of
Init
| exportTree c && isEncrypted c ->
giveup "cannot enable both encryption and exporttree"
| otherwise -> cont
Enable oldc
| exportTree c /= exportTree oldc ->
giveup "cannot change exporttree of existing special remote"
| otherwise -> cont
, if exportTree c
then giveup "exporttree=yes is not supported by this special remote"
else cont
)
-- | If the remote is exportSupported, and exporttree=yes, adjust the
-- remote to be an export.
adjustExportable :: Remote -> Annex Remote
adjustExportable r = case M.lookup "exporttree" (config r) of
Just "yes" -> ifM (isExportSupported r)
( isexport
, notexport
)
Nothing -> notexport
Just "no" -> notexport
Just _ -> error "bad exporttree value"
where
notexport = return $ r
{ exportActions = exportUnsupported
, remotetype = (remotetype r)
{ exportSupported = exportUnsupported
}
}
isexport = do
db <- openDb (uuid r)
return $ r
-- Storing a key on an export would need a way to
-- look up the file(s) that the currently exported
-- tree uses for a key; there's not currently an
-- inexpensive way to do that (getExportLocation
-- only finds files that have been stored on the
-- export already).
{ storeKey = \_ _ _ -> do
warning "remote is configured with exporttree=yes; use `git-annex export` to store content on it"
return False
-- Keys can be retrieved, but since an export
-- is not a true key/value store, the content of
-- the key has to be able to be strongly verified.
, retrieveKeyFile = \k _af dest p -> unVerified $
if maybe False (isJust . verifyKeyContent) (maybeLookupBackendVariety (keyVariety k))
then do
locs <- liftIO $ getExportLocation db k
case locs of
[] -> do
warning "unknown export location"
return False
(l:_) -> do
ea <- exportActions r
retrieveExport ea k l dest p
else do
warning $ "exported content cannot be verified due to using the " ++ formatKeyVariety (keyVariety k) ++ " backend"
return False
, retrieveKeyFileCheap = \_ _ _ -> return False
-- Removing a key from an export would need to
-- change the tree in the export log to not include
-- the file. Otherwise, conflicts when removing
-- files would not be dealt with correctly.
-- There does not seem to be a good use case for
-- removing a key from an export in any case.
, removeKey = \_k -> do
warning "dropping content from an export is not supported; use `git annex export` to export a tree that lacks the files you want to remove"
return False
-- Can't lock content on exports, since they're
-- not key/value stores, and someone else could
-- change what's exported to a file at any time.
, lockContent = Nothing
-- Check if any of the files a key was exported
-- to are present. This doesn't guarantee the
-- export contains the right content.
, checkPresent = \k -> do
ea <- exportActions r
anyM (checkPresentExport ea k)
=<< liftIO (getExportLocation db k)
, mkUnavailable = return Nothing
, getInfo = do
is <- getInfo r
return (is++[("export", "yes")])
}
-- | Remove empty directories from the export. Call after removing an
-- exported file, and after calling removeExportLocation and flushing the
-- database.
removeEmptyDirectories :: ExportActions Annex -> ExportHandle -> ExportLocation -> [Key] -> Annex Bool
removeEmptyDirectories ea db loc ks
| null (exportDirectories loc) = return True
| otherwise = case removeExportDirectory ea of
Nothing -> return True
Just removeexportdirectory -> do
ok <- allM (go removeexportdirectory)
(reverse (exportDirectories loc))
unless ok $ liftIO $ do
-- Add back to export database, so this is
-- tried again next time.
forM_ ks $ \k ->
addExportLocation db k loc
flushDbQueue db
return ok
where
go removeexportdirectory d =
ifM (liftIO $ isExportDirectoryEmpty db d)
( removeexportdirectory d
, return True
)
|
