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
|
{- 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 Logs.Transfer
import qualified Remote
import Types.Remote (AssociatedFile)
import Types.Key
import qualified Option
data TransferRequest = TransferRequest Direction Remote Key AssociatedFile
def :: [Command]
def = [withOptions options $
command "transferkeys" paramNothing seek "plumbing; transfers keys"]
options :: [Option]
options = [readFdOption, writeFdOption]
readFdOption :: Option
readFdOption = Option.field [] "readfd" paramNumber "read from this fd"
writeFdOption :: Option
writeFdOption = Option.field [] "writefd" paramNumber "write to this fd"
seek :: [CommandSeek]
seek = [withField readFdOption convertFd $ \readh ->
withField writeFdOption convertFd $ \writeh ->
withNothing $ start readh writeh]
convertFd :: Maybe String -> Annex (Maybe Handle)
convertFd Nothing = return Nothing
convertFd (Just s) = liftIO $ do
case readish s of
Nothing -> error "bad fd"
Just fd -> Just <$> fdToHandle fd
start :: Maybe Handle -> Maybe Handle -> CommandStart
start readh writeh = do
runRequests (fromMaybe stdin readh) (fromMaybe stdout writeh) runner
stop
where
runner (TransferRequest direction remote key file)
| direction == Upload =
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 = download (Remote.uuid remote) key file forwardRetry $
getViaTmp key $ Remote.retrieveKeyFile remote key file
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 [] = return ()
go _ = error "transferkeys protocol error"
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 $ join 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 Serialized a where
serialize :: a -> String
deserialize :: String -> Maybe a
instance Serialized Bool where
serialize True = "1"
serialize False = "0"
deserialize "1" = Just True
deserialize "0" = Just False
deserialize _ = Nothing
instance Serialized Direction where
serialize Upload = "u"
serialize Download = "d"
deserialize "u" = Just Upload
deserialize "d" = Just Download
deserialize _ = Nothing
instance Serialized AssociatedFile where
serialize (Just f) = f
serialize Nothing = ""
deserialize "" = Just Nothing
deserialize f = Just $ Just f
instance Serialized UUID where
serialize = fromUUID
deserialize = Just . toUUID
instance Serialized Key where
serialize = key2file
deserialize = file2key
|
