aboutsummaryrefslogtreecommitdiff
path: root/Command/TransferKeys.hs
blob: 05129005b7b6b0d1a7801226b0859753882054a4 (plain)
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