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
|
{- Amazon Glacier remotes.
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Remote.Glacier (remote) where
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Map as M
import System.Environment
import Common.Annex
import Types.Remote
import Types.Key
import qualified Git
import Config
import Remote.Helper.Special
import Remote.Helper.Encryptable
import qualified Remote.Helper.AWS as AWS
import Crypto
import Creds
import Annex.Content
import qualified Annex
type Vault = String
type Archive = FilePath
remote :: RemoteType
remote = RemoteType {
typename = "glacier",
enumerate = findSpecialRemotes "glacier",
generate = gen,
setup = glacierSetup
}
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex Remote
gen r u c = do
cst <- remoteCost r expensiveRemoteCost
return $ gen' r u c cst
gen' :: Git.Repo -> UUID -> Maybe RemoteConfig -> Int -> Remote
gen' r u c cst =
encryptableRemote c
(storeEncrypted this)
(retrieveEncrypted this)
this
where
this = Remote {
uuid = u,
cost = cst,
name = Git.repoDescribe r,
storeKey = store this,
retrieveKeyFile = retrieve this,
retrieveKeyFileCheap = retrieveCheap this,
removeKey = remove this,
hasKey = checkPresent this,
hasKeyCheap = False,
whereisKey = Nothing,
config = c,
repo = r,
localpath = Nothing,
readonly = False,
remotetype = remote
}
glacierSetup :: UUID -> RemoteConfig -> Annex RemoteConfig
glacierSetup u c = do
c' <- encryptionSetup c
let fullconfig = c' `M.union` defaults
genVault fullconfig u
gitConfigSpecialRemote u fullconfig "glacier" "true"
setRemoteCredPair fullconfig (AWS.creds u)
where
remotename = fromJust (M.lookup "name" c)
defvault = remotename ++ "-" ++ fromUUID u
defaults = M.fromList
[ ("datacenter", "us-east-1")
, ("vault", defvault)
]
store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
store r k _f _p
| keySize k == Just 0 = do
warning "Cannot store empty files in Glacier."
return False
| otherwise = do
src <- inRepo $ gitAnnexLocation k
storeHelper r k src
storeEncrypted :: Remote -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
storeEncrypted r (cipher, enck) k _p =
-- With current glacier-cli UI, have to encrypt to a temp file.
withTmp enck $ \tmp -> do
f <- inRepo $ gitAnnexLocation k
liftIO $ encrypt cipher (feedFile f) $
readBytes $ L.writeFile tmp
storeHelper r enck tmp
{- Glacier cannot store empty files. So empty keys are handled by
- doing nothing on storage, and re-creating the empty file on retrieve. -}
storeHelper :: Remote -> Key -> FilePath -> Annex Bool
storeHelper r k file = do
showOutput
glacierAction r
[ Param "archive"
, Param "upload"
, Param "--name", Param $ archive r k
, Param $ remoteVault r
, File file
]
retrieve :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
retrieve r k _f d = retrieveHelper r k d
retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool
retrieveCheap _ _ _ = return False
retrieveEncrypted :: Remote -> (Cipher, Key) -> Key -> FilePath -> Annex Bool
retrieveEncrypted r (cipher, enck) _k d = do
withTmp enck $ \tmp -> do
ok <- retrieveHelper r enck tmp
if ok
then liftIO $ decrypt cipher (feedFile tmp) $
readBytes $ \content -> do
L.writeFile d content
return True
else return False
retrieveHelper :: Remote -> Key -> FilePath -> Annex Bool
retrieveHelper r k file = do
showOutput
ok <- glacierAction r
[ Param "archive"
, Param "retrieve"
, Param "-o", File file
, Param $ remoteVault r
, Param $ archive r k
]
unless ok $
showLongNote "Recommend you wait up to 4 hours, and then run this command again."
return ok
remove :: Remote -> Key -> Annex Bool
remove r k = glacierAction r
[ Param "archive"
, Param "delete"
, Param $ remoteVault r
, Param $ archive r k
]
checkPresent :: Remote -> Key -> Annex (Either String Bool)
checkPresent r k = do
showAction $ "checking " ++ name r
go =<< glacierEnv (fromJust $ config r) (uuid r)
where
go Nothing = return $ Left "cannot check glacier"
go (Just env) = do
{- glacier checkpresent outputs the archive name to stdout if
- it's present. -}
v <- liftIO $ catchMsgIO $
readProcessEnv "glacier" (toCommand params) (Just env)
case v of
Right s -> do
let probablypresent = key2file k `elem` lines s
if probablypresent
then ifM (Annex.getFlag "trustglacier")
( return $ Right True, untrusted )
else return $ Right False
Left e -> return $ Left e
params =
[ Param "archive"
, Param "checkpresent"
, Param $ remoteVault r
, Param "--quiet"
, Param $ archive r k
]
untrusted = do
showLongNote $ unlines
[ "Glacier's inventory says it has a copy."
, "However, the inventory could be out of date, if it was recently removed."
, "(Use --trust-glacier if you're sure it's still in Glacier.)"
, ""
]
return $ Right False
glacierAction :: Remote -> [CommandParam] -> Annex Bool
glacierAction r params = do
when (isNothing $ config r) $
error $ "Missing configuration for special remote " ++ name r
runGlacier (fromJust $ config r) (uuid r) params
runGlacier :: RemoteConfig -> UUID -> [CommandParam] -> Annex Bool
runGlacier c u params = go =<< glacierEnv c u
where
go Nothing = return False
go (Just env) = liftIO $
boolSystemEnv "glacier" (datacenter:params) (Just env)
datacenter = Param $ "--region=" ++
(fromJust $ M.lookup "datacenter" c)
glacierEnv :: RemoteConfig -> UUID -> Annex (Maybe [(String, String)])
glacierEnv c u = go =<< getRemoteCredPair "glacier" c creds
where
go Nothing = return Nothing
go (Just (user, pass)) = do
env <- liftIO getEnvironment
return $ Just $ (uk, user):(pk, pass):env
creds = AWS.creds u
(uk, pk) = credPairEnvironment creds
remoteVault :: Remote -> Vault
remoteVault = vault . fromJust . config
vault :: RemoteConfig -> Vault
vault = fromJust . M.lookup "vault"
archive :: Remote -> Key -> Archive
archive r k = fileprefix ++ key2file k
where
fileprefix = M.findWithDefault "" "fileprefix" $ fromJust $ config r
-- glacier vault create will succeed even if the vault already exists.
genVault :: RemoteConfig -> UUID -> Annex ()
genVault c u = unlessM (runGlacier c u params) $
error "Failed creating glacier vault."
where
params =
[ Param "vault"
, Param "create"
, Param $ vault c
]
|
