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
|
{- Tahoe-LAFS special remotes.
-
- Tahoe capabilities for accessing objects stored in the remote
- are preserved in the remote state log.
-
- In order to allow multiple clones of a repository to access the same
- tahoe repository, git-annex needs to store the introducer furl,
- and the shared-convergence-secret. These are stored in the remote
- configuration, when embedcreds is enabled.
-
- Using those creds, git-annex sets up a tahoe configuration directory in
- ~/.tahoe/git-annex/UUID/
-
- Tahoe has its own encryption, so git-annex's encryption is not used.
-
- Copyright 2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
module Remote.Tahoe (remote) where
import qualified Data.Map as M
import Data.Aeson
import Data.ByteString.Lazy.UTF8 (fromString)
import Common.Annex
import Types.Remote
import qualified Git
import Config
import Config.Cost
import Remote.Helper.Special
import Annex.UUID
import Annex.Content
import Logs.RemoteState
import Utility.UserInfo
import Utility.Metered
import Utility.Env
type TahoeConfigDir = FilePath
type SharedConvergenceSecret = String
type IntroducerFurl = String
type Capability = String
remote :: RemoteType
remote = RemoteType {
typename = "tahoe",
enumerate = findSpecialRemotes "tahoe",
generate = gen,
setup = tahoeSetup
}
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
gen r u c gc = do
cst <- remoteCost gc expensiveRemoteCost
configdir <- liftIO $ maybe (defaultTahoeConfigDir u) return (remoteAnnexTahoe gc)
return $ Just $ Remote {
uuid = u,
cost = cst,
name = Git.repoDescribe r,
storeKey = store u configdir,
retrieveKeyFile = retrieve u configdir,
retrieveKeyFileCheap = \_ _ -> return False,
removeKey = remove,
hasKey = checkPresent u configdir,
hasKeyCheap = False,
whereisKey = Nothing,
remoteFsck = Nothing,
repairRepo = Nothing,
config = c,
repo = r,
gitconfig = gc,
localpath = Nothing,
readonly = False,
globallyAvailable = True,
remotetype = remote
}
tahoeSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
tahoeSetup mu c = do
furl <- fromMaybe (fromMaybe missingfurl $ M.lookup furlk c)
<$> liftIO (getEnv "TAHOE_FURL")
u <- maybe (liftIO genUUID) return mu
configdir <- liftIO $ defaultTahoeConfigDir u
scs <- liftIO $ tahoeConfigure configdir furl (M.lookup scsk c)
let c' = if M.lookup "embedcreds" c == Just "yes"
then flip M.union c $ M.fromList
[ (furlk, furl)
, (scsk, scs)
]
else c
gitConfigSpecialRemote u c' "tahoe" configdir
return (c', u)
where
scsk = "shared-convergence-secret"
furlk = "introducer-furl"
missingfurl = error "Set TAHOE_FURL to the introducer furl to use."
store :: UUID -> TahoeConfigDir -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
store u configdir k _f _p = sendAnnex k noop $ \src -> do
liftIO $ startTahoeDaemon configdir
parsePut <$> liftIO (readTahoe configdir "put" [File src]) >>= maybe
(return False)
(\cap -> storeCapability u k cap >> return True)
retrieve :: UUID -> TahoeConfigDir -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
retrieve u configdir k _f d _p = go =<< getCapability u k
where
go Nothing = return False
go (Just cap) = liftIO $ do
startTahoeDaemon configdir
boolTahoe configdir "get" [Param cap, File d]
remove :: Key -> Annex Bool
remove _k = do
warning "content cannot be removed from tahoe remote"
return False
checkPresent :: UUID -> TahoeConfigDir -> Key -> Annex (Either String Bool)
checkPresent u configdir k = go =<< getCapability u k
where
go Nothing = return (Right False)
go (Just cap) = liftIO $ do
startTahoeDaemon configdir
parseCheck <$> readTahoe configdir "check"
[ Param "--raw"
, Param cap
]
defaultTahoeConfigDir :: UUID -> IO TahoeConfigDir
defaultTahoeConfigDir u = do
h <- myHomeDir
return $ h </> ".tahoe" </> "git-annex" </> fromUUID u
tahoeConfigure :: TahoeConfigDir -> IntroducerFurl -> Maybe SharedConvergenceSecret -> IO SharedConvergenceSecret
tahoeConfigure configdir furl mscs = do
unlessM (createClient configdir furl) $
error "tahoe create-client failed"
maybe noop (writeSharedConvergenceSecret configdir) mscs
startTahoeDaemon configdir
getSharedConvergenceSecret configdir
createClient :: TahoeConfigDir -> IntroducerFurl -> IO Bool
createClient configdir furl = do
createDirectoryIfMissing True (parentDir configdir)
boolTahoe configdir "create-client"
[ Param "--nickname", Param "git-annex"
, Param "--introducer", Param furl
]
writeSharedConvergenceSecret :: TahoeConfigDir -> SharedConvergenceSecret -> IO ()
writeSharedConvergenceSecret configdir scs =
writeFile (convergenceFile configdir) (unlines [scs])
{- The tahoe daemon writes the convergenceFile shortly after it starts
- (it does not need to connect to the network). So, try repeatedly to read
- the file, for up to 1 minute. To avoid reading a partially written
- file, look for the newline after the value. -}
getSharedConvergenceSecret :: TahoeConfigDir -> IO SharedConvergenceSecret
getSharedConvergenceSecret configdir = go (60 :: Int)
where
f = convergenceFile configdir
go n
| n == 0 = error $ "tahoe did not write " ++ f ++ " after 1 minute. Perhaps the daemon failed to start?"
| otherwise = do
v <- catchMaybeIO (readFile f)
case v of
Just s | "\n" `isSuffixOf` s || "\r" `isSuffixOf` s ->
return $ takeWhile (`notElem` "\n\r") s
_ -> go (n - 1)
convergenceFile :: TahoeConfigDir -> FilePath
convergenceFile configdir = configdir </> "private" </> "convergence"
{- XXX Avoid starting tahoe if it is already running. -}
startTahoeDaemon :: TahoeConfigDir -> IO ()
startTahoeDaemon configdir = void $ boolTahoe configdir "start" []
boolTahoe :: TahoeConfigDir -> String -> [CommandParam] -> IO Bool
boolTahoe configdir command params = boolSystem "tahoe" $
tahoeParams configdir command params
readTahoe :: TahoeConfigDir -> String -> [CommandParam] -> IO String
readTahoe configdir command params = catchDefaultIO "" $
readProcess "tahoe" $ toCommand $
tahoeParams configdir command params
tahoeParams :: TahoeConfigDir -> String -> [CommandParam] -> [CommandParam]
tahoeParams configdir command params =
Param command : Param "-d" : File configdir : params
storeCapability :: UUID -> Key -> Capability -> Annex ()
storeCapability u k cap = setRemoteState u k cap
getCapability :: UUID -> Key -> Annex (Maybe Capability)
getCapability u k = getRemoteState u k
{- tahoe put outputs a single line, containing the capability. -}
parsePut :: String -> Maybe Capability
parsePut s = case lines s of
[cap] | "URI" `isPrefixOf` cap -> Just cap
_ -> Nothing
{- tahoe check --raw outputs a json document.
- Its contents will vary (for LIT capabilities, it lacks most info),
- but should always contain a results object with a healthy value
- that's true or false.
-}
parseCheck :: String -> Either String Bool
parseCheck s = maybe parseerror (Right . healthy . results) (decode $ fromString s)
where
parseerror
| null s = Left "tahoe check failed to run"
| otherwise = Left "unable to parse tahoe check output"
data CheckRet = CheckRet { results :: Results }
data Results = Results { healthy :: Bool }
instance FromJSON CheckRet where
parseJSON (Object v) = CheckRet
<$> v .: "results"
parseJSON _ = mzero
instance FromJSON Results where
parseJSON (Object v) = Results
<$> v .: "healthy"
parseJSON _ = mzero
|
