2013-03-19 16:58:36 -04:00
|
|
|
{- git-annex command, used internally by assistant
|
|
|
|
-
|
2015-01-21 12:50:09 -04:00
|
|
|
- Copyright 2012, 2013 Joey Hess <id@joeyh.name>
|
2013-03-19 16:58:36 -04:00
|
|
|
-
|
2019-03-13 15:48:14 -04:00
|
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
2013-03-19 16:58:36 -04:00
|
|
|
-}
|
|
|
|
|
|
|
|
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
|
|
|
|
|
|
|
|
module Command.TransferKeys where
|
|
|
|
|
|
|
|
import Command
|
|
|
|
import Annex.Content
|
|
|
|
import Logs.Location
|
2014-03-22 10:42:38 -04:00
|
|
|
import Annex.Transfer
|
2013-03-19 16:58:36 -04:00
|
|
|
import qualified Remote
|
2015-04-03 15:33:28 -04:00
|
|
|
import Utility.SimpleProtocol (dupIoHandles)
|
2014-05-19 16:19:33 -04:00
|
|
|
import Git.Types (RemoteName)
|
2016-05-16 14:49:12 -04:00
|
|
|
import qualified Database.Keys
|
2013-03-19 16:58:36 -04:00
|
|
|
|
|
|
|
data TransferRequest = TransferRequest Direction Remote Key AssociatedFile
|
|
|
|
|
2015-07-08 12:33:27 -04:00
|
|
|
cmd :: Command
|
2015-07-08 15:08:02 -04:00
|
|
|
cmd = command "transferkeys" SectionPlumbing "transfers keys"
|
|
|
|
paramNothing (withParams seek)
|
2013-03-19 16:58:36 -04:00
|
|
|
|
2015-07-08 15:08:02 -04:00
|
|
|
seek :: CmdParams -> CommandSeek
|
2018-10-01 14:12:06 -04:00
|
|
|
seek = withNothing (commandAction start)
|
2013-03-19 16:58:36 -04:00
|
|
|
|
2013-12-10 23:19:18 -04:00
|
|
|
start :: CommandStart
|
2014-04-08 14:02:25 -04:00
|
|
|
start = do
|
2015-04-03 15:33:28 -04:00
|
|
|
(readh, writeh) <- liftIO dupIoHandles
|
2013-12-10 23:19:18 -04:00
|
|
|
runRequests readh writeh runner
|
2013-03-19 16:58:36 -04:00
|
|
|
stop
|
|
|
|
where
|
|
|
|
runner (TransferRequest direction remote key file)
|
2014-03-22 10:42:38 -04:00
|
|
|
| direction == Upload = notifyTransfer direction file $
|
2018-03-29 13:04:07 -04:00
|
|
|
upload (Remote.uuid remote) key file stdRetry $ \p -> do
|
2013-03-19 16:58:36 -04:00
|
|
|
ok <- Remote.storeKey remote key file p
|
|
|
|
when ok $
|
|
|
|
Remote.logStatus remote key InfoPresent
|
|
|
|
return ok
|
2014-03-22 10:42:38 -04:00
|
|
|
| otherwise = notifyTransfer direction file $
|
2018-03-29 13:04:07 -04:00
|
|
|
download (Remote.uuid remote) key file stdRetry $ \p ->
|
2018-06-21 13:34:11 -04:00
|
|
|
getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key $ \t -> do
|
2016-05-16 14:49:12 -04:00
|
|
|
r <- Remote.retrieveKeyFile remote key file t p
|
|
|
|
-- Make sure we get the current
|
|
|
|
-- associated files data for the key,
|
|
|
|
-- not old cached data.
|
|
|
|
Database.Keys.closeDb
|
|
|
|
return r
|
2013-03-19 16:58:36 -04:00
|
|
|
|
|
|
|
runRequests
|
|
|
|
:: Handle
|
|
|
|
-> Handle
|
|
|
|
-> (TransferRequest -> Annex Bool)
|
|
|
|
-> Annex ()
|
2013-03-20 13:18:12 -04:00
|
|
|
runRequests readh writeh a = do
|
2016-12-24 14:46:31 -04:00
|
|
|
liftIO $ hSetBuffering readh NoBuffering
|
2013-03-20 13:18:12 -04:00
|
|
|
go =<< readrequests
|
2013-03-19 16:58:36 -04:00
|
|
|
where
|
2014-10-09 14:53:13 -04:00
|
|
|
go (d:rn:k:f:rest) = do
|
2014-05-19 16:19:33 -04:00
|
|
|
case (deserialize d, deserialize rn, deserialize k, deserialize f) of
|
|
|
|
(Just direction, Just remotename, Just key, Just file) -> do
|
|
|
|
mremote <- Remote.byName' remotename
|
2013-03-19 16:58:36 -04:00
|
|
|
case mremote of
|
2014-05-19 16:19:33 -04:00
|
|
|
Left _ -> sendresult False
|
|
|
|
Right remote -> sendresult =<< a
|
2013-03-19 16:58:36 -04:00
|
|
|
(TransferRequest direction remote key file)
|
|
|
|
_ -> sendresult False
|
|
|
|
go rest
|
2013-04-02 15:18:03 -04:00
|
|
|
go [] = noop
|
|
|
|
go [""] = noop
|
|
|
|
go v = error $ "transferkeys protocol error: " ++ show v
|
2013-03-19 16:58:36 -04:00
|
|
|
|
|
|
|
readrequests = liftIO $ split fieldSep <$> hGetContents readh
|
|
|
|
sendresult b = liftIO $ do
|
|
|
|
hPutStrLn writeh $ serialize b
|
|
|
|
hFlush writeh
|
|
|
|
|
2014-05-19 16:19:33 -04:00
|
|
|
sendRequest :: Transfer -> TransferInfo -> Handle -> IO ()
|
2015-07-09 16:05:45 -04:00
|
|
|
sendRequest t tinfo h = do
|
2013-04-22 20:24:53 -04:00
|
|
|
hPutStr h $ intercalate fieldSep
|
2013-03-19 18:46:29 -04:00
|
|
|
[ serialize (transferDirection t)
|
2019-01-01 13:49:19 -04:00
|
|
|
, maybe (serialize ((fromUUID (transferUUID t)) :: String))
|
2014-05-19 16:19:33 -04:00
|
|
|
(serialize . Remote.name)
|
2015-07-09 16:05:45 -04:00
|
|
|
(transferRemote tinfo)
|
2013-03-19 18:46:29 -04:00
|
|
|
, serialize (transferKey t)
|
2015-07-09 16:05:45 -04:00
|
|
|
, serialize (associatedFile tinfo)
|
2013-03-20 13:18:12 -04:00
|
|
|
, "" -- adds a trailing null
|
2013-03-19 16:58:36 -04:00
|
|
|
]
|
|
|
|
hFlush h
|
|
|
|
|
2013-03-19 18:46:29 -04:00
|
|
|
readResponse :: Handle -> IO Bool
|
|
|
|
readResponse h = fromMaybe False . deserialize <$> hGetLine h
|
|
|
|
|
2013-03-19 16:58:36 -04:00
|
|
|
fieldSep :: String
|
|
|
|
fieldSep = "\0"
|
|
|
|
|
2014-01-21 16:08:19 -04:00
|
|
|
class TCSerialized a where
|
2013-03-19 16:58:36 -04:00
|
|
|
serialize :: a -> String
|
|
|
|
deserialize :: String -> Maybe a
|
|
|
|
|
2014-01-21 16:08:19 -04:00
|
|
|
instance TCSerialized Bool where
|
2013-03-19 16:58:36 -04:00
|
|
|
serialize True = "1"
|
|
|
|
serialize False = "0"
|
|
|
|
deserialize "1" = Just True
|
|
|
|
deserialize "0" = Just False
|
|
|
|
deserialize _ = Nothing
|
|
|
|
|
2014-01-21 16:08:19 -04:00
|
|
|
instance TCSerialized Direction where
|
2013-03-19 16:58:36 -04:00
|
|
|
serialize Upload = "u"
|
|
|
|
serialize Download = "d"
|
|
|
|
deserialize "u" = Just Upload
|
|
|
|
deserialize "d" = Just Download
|
|
|
|
deserialize _ = Nothing
|
|
|
|
|
2014-01-21 16:08:19 -04:00
|
|
|
instance TCSerialized AssociatedFile where
|
2019-12-05 11:40:10 -04:00
|
|
|
serialize (AssociatedFile (Just f)) = fromRawFilePath f
|
2017-03-10 13:12:24 -04:00
|
|
|
serialize (AssociatedFile Nothing) = ""
|
|
|
|
deserialize "" = Just (AssociatedFile Nothing)
|
2019-12-05 11:40:10 -04:00
|
|
|
deserialize f = Just (AssociatedFile (Just (toRawFilePath f)))
|
2013-03-19 16:58:36 -04:00
|
|
|
|
2014-05-19 16:19:33 -04:00
|
|
|
instance TCSerialized RemoteName where
|
|
|
|
serialize n = n
|
|
|
|
deserialize n = Just n
|
2013-03-19 16:58:36 -04:00
|
|
|
|
2014-01-21 16:08:19 -04:00
|
|
|
instance TCSerialized Key where
|
2019-01-14 13:03:35 -04:00
|
|
|
serialize = serializeKey
|
|
|
|
deserialize = deserializeKey
|