1{- git-annex command, used internally by assistant in version
2 - 8.20201127 and older and provided only to avoid upgrade breakage.
3 - Remove at some point when such old versions of git-annex are unlikely
4 - to be running any longer.
5 -
6 - Copyright 2012, 2013 Joey Hess <id@joeyh.name>
7 -
8 - Licensed under the GNU AGPL version 3 or higher.
9 -}
10
11{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
12
13module Command.TransferKeys where
14
15import Command
16import Annex.Content
17import Logs.Location
18import Annex.Transfer
19import qualified Remote
20import Utility.SimpleProtocol (dupIoHandles)
21import Git.Types (RemoteName)
22import qualified Database.Keys
23import Annex.BranchState
24
25data TransferRequest = TransferRequest Direction Remote Key AssociatedFile
26
27cmd :: Command
28cmd = command "transferkeys" SectionPlumbing "transfers keys (deprecated)"
29	paramNothing (withParams seek)
30
31seek :: CmdParams -> CommandSeek
32seek = withNothing (commandAction start)
33
34start :: CommandStart
35start = do
36	enableInteractiveBranchAccess
37	(readh, writeh) <- liftIO dupIoHandles
38	runRequests readh writeh runner
39	stop
40  where
41	runner (TransferRequest direction remote key file)
42		| direction == Upload = notifyTransfer direction file $
43			upload' (Remote.uuid remote) key file Nothing stdRetry $ \p -> do
44				tryNonAsync (Remote.storeKey remote key file p) >>= \case
45					Left e -> do
46						warning (show e)
47						return False
48					Right () -> do
49						Remote.logStatus remote key InfoPresent
50						return True
51		| otherwise = notifyTransfer direction file $
52			download' (Remote.uuid remote) key file Nothing stdRetry $ \p ->
53				logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do
54					r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) >>= \case
55						Left e -> do
56							warning (show e)
57							return (False, UnVerified)
58						Right v -> return (True, v)
59					-- Make sure we get the current
60					-- associated files data for the key,
61					-- not old cached data.
62					Database.Keys.closeDb
63					return r
64
65runRequests
66	:: Handle
67	-> Handle
68	-> (TransferRequest -> Annex Bool)
69	-> Annex ()
70runRequests readh writeh a = do
71	liftIO $ hSetBuffering readh NoBuffering
72	go =<< readrequests
73  where
74	go (d:rn:k:f:rest) = do
75		case (deserialize d, deserialize rn, deserialize k, deserialize f) of
76			(Just direction, Just remotename, Just key, Just file) -> do
77				mremote <- Remote.byName' remotename
78				case mremote of
79					Left _ -> sendresult False
80					Right remote -> sendresult =<< a
81						(TransferRequest direction remote key file)
82			_ -> sendresult False
83		go rest
84	go [] = noop
85	go [""] = noop
86	go v = error $ "transferkeys protocol error: " ++ show v
87
88	readrequests = liftIO $ split fieldSep <$> hGetContents readh
89	sendresult b = liftIO $ do
90		hPutStrLn writeh $ serialize b
91		hFlush writeh
92
93sendRequest :: Transfer -> TransferInfo -> Handle -> IO ()
94sendRequest t tinfo h = do
95	hPutStr h $ intercalate fieldSep
96		[ serialize (transferDirection t)
97		, maybe (serialize ((fromUUID (transferUUID t)) :: String))
98			(serialize . Remote.name)
99			(transferRemote tinfo)
100		, serialize (transferKey t)
101		, serialize (associatedFile tinfo)
102		, "" -- adds a trailing null
103		]
104	hFlush h
105
106readResponse :: Handle -> IO Bool
107readResponse h = fromMaybe False . deserialize <$> hGetLine h
108
109fieldSep :: String
110fieldSep = "\0"
111
112class TCSerialized a where
113	serialize :: a -> String
114	deserialize :: String -> Maybe a
115
116instance TCSerialized Bool where
117	serialize True = "1"
118	serialize False = "0"
119	deserialize "1" = Just True
120	deserialize "0" = Just False
121	deserialize _ = Nothing
122
123instance TCSerialized Direction where
124	serialize Upload = "u"
125	serialize Download = "d"
126	deserialize "u" = Just Upload
127	deserialize "d" = Just Download
128	deserialize _ = Nothing
129
130instance TCSerialized AssociatedFile where
131	serialize (AssociatedFile (Just f)) = fromRawFilePath f
132	serialize (AssociatedFile Nothing) = ""
133	deserialize "" = Just (AssociatedFile Nothing)
134	deserialize f = Just (AssociatedFile (Just (toRawFilePath f)))
135
136instance TCSerialized RemoteName where
137	serialize n = n
138	deserialize n = Just n
139
140instance TCSerialized Key where
141	serialize = serializeKey
142	deserialize = deserializeKey
143