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
|
{- git-annex command, used internally by assistant
-
- Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
module Command.TransferKeys where
import Common.Annex
import Command
import Annex.Content
import Logs.Location
import Annex.Transfer
import qualified Remote
import Types.Key
import Utility.SimpleProtocol (ioHandles)
data TransferRequest = TransferRequest Direction Remote Key AssociatedFile
def :: [Command]
def = [command "transferkeys" paramNothing seek
SectionPlumbing "transfers keys"]
seek :: CommandSeek
seek = withNothing start
start :: CommandStart
start = do
(readh, writeh) <- liftIO ioHandles
runRequests readh writeh runner
stop
where
runner (TransferRequest direction remote key file)
| direction == Upload = notifyTransfer direction file $
upload (Remote.uuid remote) key file forwardRetry $ \p -> do
ok <- Remote.storeKey remote key file p
when ok $
Remote.logStatus remote key InfoPresent
return ok
| otherwise = notifyTransfer direction file $
download (Remote.uuid remote) key file forwardRetry $ \p ->
getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t p
runRequests
:: Handle
-> Handle
-> (TransferRequest -> Annex Bool)
-> Annex ()
runRequests readh writeh a = do
liftIO $ do
hSetBuffering readh NoBuffering
fileEncoding readh
fileEncoding writeh
go =<< readrequests
where
go (d:u:k:f:rest) = do
case (deserialize d, deserialize u, deserialize k, deserialize f) of
(Just direction, Just uuid, Just key, Just file) -> do
mremote <- Remote.remoteFromUUID uuid
case mremote of
Nothing -> sendresult False
Just remote -> sendresult =<< a
(TransferRequest direction remote key file)
_ -> sendresult False
go rest
go [] = noop
go [""] = noop
go v = error $ "transferkeys protocol error: " ++ show v
readrequests = liftIO $ split fieldSep <$> hGetContents readh
sendresult b = liftIO $ do
hPutStrLn writeh $ serialize b
hFlush writeh
sendRequest :: Transfer -> AssociatedFile -> Handle -> IO ()
sendRequest t f h = do
hPutStr h $ intercalate fieldSep
[ serialize (transferDirection t)
, serialize (transferUUID t)
, serialize (transferKey t)
, serialize f
, "" -- adds a trailing null
]
hFlush h
readResponse :: Handle -> IO Bool
readResponse h = fromMaybe False . deserialize <$> hGetLine h
fieldSep :: String
fieldSep = "\0"
class TCSerialized a where
serialize :: a -> String
deserialize :: String -> Maybe a
instance TCSerialized Bool where
serialize True = "1"
serialize False = "0"
deserialize "1" = Just True
deserialize "0" = Just False
deserialize _ = Nothing
instance TCSerialized Direction where
serialize Upload = "u"
serialize Download = "d"
deserialize "u" = Just Upload
deserialize "d" = Just Download
deserialize _ = Nothing
instance TCSerialized AssociatedFile where
serialize (Just f) = f
serialize Nothing = ""
deserialize "" = Just Nothing
deserialize f = Just $ Just f
instance TCSerialized UUID where
serialize = fromUUID
deserialize = Just . toUUID
instance TCSerialized Key where
serialize = key2file
deserialize = file2key
|
