1{- External special remote data types. 2 - 3 - Copyright 2013-2020 Joey Hess <id@joeyh.name> 4 - 5 - Licensed under the GNU AGPL version 3 or higher. 6 -} 7 8{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, RankNTypes #-} 9{-# LANGUAGE GeneralizedNewtypeDeriving #-} 10{-# OPTIONS_GHC -fno-warn-orphans #-} 11 12module Remote.External.Types ( 13 External(..), 14 newExternal, 15 ExternalType, 16 ExternalState(..), 17 PrepareStatus(..), 18 ExtensionList(..), 19 supportedExtensionList, 20 asyncExtensionEnabled, 21 ExternalAsync(..), 22 ExternalAsyncRelay(..), 23 Proto.parseMessage, 24 Proto.Sendable(..), 25 Proto.Receivable(..), 26 Request(..), 27 SafeKey, 28 mkSafeKey, 29 needsPREPARE, 30 Response(..), 31 RemoteRequest(..), 32 RemoteResponse(..), 33 ExceptionalMessage(..), 34 AsyncMessage(..), 35 AsyncWrapped(..), 36 ToAsyncWrapped(..), 37 JobId(..), 38 ErrorMsg, 39 Setting, 40 Description, 41 ProtocolVersion, 42 supportedProtocolVersions, 43) where 44 45import Annex.Common 46import Types.StandardGroups (PreferredContentExpression) 47import Utility.Metered (BytesProcessed(..)) 48import Types.Transfer (Direction(..)) 49import Config.Cost (Cost) 50import Types.RemoteState 51import Types.RemoteConfig 52import Types.Export 53import Types.Availability (Availability(..)) 54import Types.Key 55import Git.Types 56import Utility.Url (URLString) 57import qualified Utility.SimpleProtocol as Proto 58 59import Control.Concurrent.STM 60import Network.URI 61import Data.Char 62import Text.Read 63 64data External = External 65 { externalType :: ExternalType 66 , externalUUID :: Maybe UUID 67 , externalState :: TVar [ExternalState] 68 -- ^ Contains states for external special remote processes 69 -- that are not currently in use. 70 , externalLastPid :: TVar PID 71 , externalDefaultConfig :: ParsedRemoteConfig 72 , externalGitConfig :: Maybe RemoteGitConfig 73 , externalRemoteName :: Maybe RemoteName 74 , externalRemoteStateHandle :: Maybe RemoteStateHandle 75 , externalAsync :: TMVar ExternalAsync 76 } 77 78newExternal :: ExternalType -> Maybe UUID -> ParsedRemoteConfig -> Maybe RemoteGitConfig -> Maybe RemoteName -> Maybe RemoteStateHandle -> Annex External 79newExternal externaltype u c gc rn rs = liftIO $ External 80 <$> pure externaltype 81 <*> pure u 82 <*> atomically (newTVar []) 83 <*> atomically (newTVar 0) 84 <*> pure c 85 <*> pure gc 86 <*> pure rn 87 <*> pure rs 88 <*> atomically (newTMVar UncheckedExternalAsync) 89 90type ExternalType = String 91 92data ExternalState = ExternalState 93 { externalSend :: forall t. (Proto.Sendable t, ToAsyncWrapped t) => t -> IO () 94 , externalReceive :: IO (Maybe String) 95 , externalShutdown :: Bool -> IO () 96 , externalPrepared :: TMVar PrepareStatus 97 , externalConfig :: TMVar ParsedRemoteConfig 98 , externalConfigChanges :: TMVar (RemoteConfig -> RemoteConfig) 99 } 100 101type PID = Int 102 103-- List of extensions to the protocol. 104newtype ExtensionList = ExtensionList { fromExtensionList :: [String] } 105 deriving (Show, Monoid, Semigroup) 106 107supportedExtensionList :: ExtensionList 108supportedExtensionList = ExtensionList 109 [ "INFO" 110 , "GETGITREMOTENAME" 111 , asyncExtension 112 ] 113 114asyncExtension :: String 115asyncExtension = "ASYNC" 116 117asyncExtensionEnabled :: ExtensionList -> Bool 118asyncExtensionEnabled l = asyncExtension `elem` fromExtensionList l 119 120-- When the async extension is in use, a single external process 121-- is started and used for all requests. 122data ExternalAsync 123 = ExternalAsync ExternalAsyncRelay 124 | NoExternalAsync 125 | UncheckedExternalAsync 126 127data ExternalAsyncRelay = ExternalAsyncRelay 128 { asyncRelayExternalState :: IO ExternalState 129 } 130 131data PrepareStatus = Unprepared | Prepared | FailedPrepare ErrorMsg 132 133-- The protocol does not support keys with spaces in their names; 134-- SafeKey can only be constructed for keys that are safe to use with the 135-- protocol. 136newtype SafeKey = SafeKey Key 137 deriving (Show) 138 139mkSafeKey :: Key -> Either String SafeKey 140mkSafeKey k 141 | any isSpace (decodeBS $ fromKey keyName k) = Left $ concat 142 [ "Sorry, this file cannot be stored on an external special remote because its key's name contains a space. " 143 , "To avoid this problem, you can run: git-annex migrate --backend=" 144 , decodeBS (formatKeyVariety (fromKey keyVariety k)) 145 , " and pass it the name of the file" 146 ] 147 | otherwise = Right (SafeKey k) 148 149fromSafeKey :: SafeKey -> Key 150fromSafeKey (SafeKey k) = k 151 152instance Proto.Serializable SafeKey where 153 serialize = Proto.serialize . fromSafeKey 154 deserialize = fmap SafeKey . Proto.deserialize 155 156-- Messages that can be sent to the external remote to request it do something. 157data Request 158 = EXTENSIONS ExtensionList 159 | PREPARE 160 | INITREMOTE 161 | GETCOST 162 | GETAVAILABILITY 163 | CLAIMURL URLString 164 | CHECKURL URLString 165 | TRANSFER Direction SafeKey FilePath 166 | CHECKPRESENT SafeKey 167 | REMOVE SafeKey 168 | WHEREIS SafeKey 169 | LISTCONFIGS 170 | GETINFO 171 | EXPORTSUPPORTED 172 | EXPORT ExportLocation 173 | TRANSFEREXPORT Direction SafeKey FilePath 174 | CHECKPRESENTEXPORT SafeKey 175 | REMOVEEXPORT SafeKey 176 | REMOVEEXPORTDIRECTORY ExportDirectory 177 | RENAMEEXPORT SafeKey ExportLocation 178 deriving (Show) 179 180-- Does PREPARE need to have been sent before this request? 181needsPREPARE :: Request -> Bool 182needsPREPARE PREPARE = False 183needsPREPARE (EXTENSIONS _) = False 184needsPREPARE INITREMOTE = False 185needsPREPARE EXPORTSUPPORTED = False 186needsPREPARE LISTCONFIGS = False 187needsPREPARE _ = True 188 189instance Proto.Sendable Request where 190 formatMessage (EXTENSIONS l) = ["EXTENSIONS", Proto.serialize l] 191 formatMessage PREPARE = ["PREPARE"] 192 formatMessage INITREMOTE = ["INITREMOTE"] 193 formatMessage GETCOST = ["GETCOST"] 194 formatMessage GETAVAILABILITY = ["GETAVAILABILITY"] 195 formatMessage (CLAIMURL url) = [ "CLAIMURL", Proto.serialize url ] 196 formatMessage (CHECKURL url) = [ "CHECKURL", Proto.serialize url ] 197 formatMessage (TRANSFER direction key file) = 198 [ "TRANSFER" 199 , Proto.serialize direction 200 , Proto.serialize key 201 , Proto.serialize file 202 ] 203 formatMessage (CHECKPRESENT key) = 204 [ "CHECKPRESENT", Proto.serialize key ] 205 formatMessage (REMOVE key) = [ "REMOVE", Proto.serialize key ] 206 formatMessage (WHEREIS key) = [ "WHEREIS", Proto.serialize key ] 207 formatMessage LISTCONFIGS = [ "LISTCONFIGS" ] 208 formatMessage GETINFO = [ "GETINFO" ] 209 formatMessage EXPORTSUPPORTED = ["EXPORTSUPPORTED"] 210 formatMessage (EXPORT loc) = [ "EXPORT", Proto.serialize loc ] 211 formatMessage (TRANSFEREXPORT direction key file) = 212 [ "TRANSFEREXPORT" 213 , Proto.serialize direction 214 , Proto.serialize key 215 , Proto.serialize file 216 ] 217 formatMessage (CHECKPRESENTEXPORT key) = 218 [ "CHECKPRESENTEXPORT", Proto.serialize key ] 219 formatMessage (REMOVEEXPORT key) = 220 [ "REMOVEEXPORT", Proto.serialize key ] 221 formatMessage (REMOVEEXPORTDIRECTORY dir) = 222 [ "REMOVEEXPORTDIRECTORY", Proto.serialize dir ] 223 formatMessage (RENAMEEXPORT key newloc) = 224 [ "RENAMEEXPORT" 225 , Proto.serialize key 226 , Proto.serialize newloc 227 ] 228 229-- Responses the external remote can make to requests. 230data Response 231 = EXTENSIONS_RESPONSE ExtensionList 232 | PREPARE_SUCCESS 233 | PREPARE_FAILURE ErrorMsg 234 | TRANSFER_SUCCESS Direction Key 235 | TRANSFER_FAILURE Direction Key ErrorMsg 236 | CHECKPRESENT_SUCCESS Key 237 | CHECKPRESENT_FAILURE Key 238 | CHECKPRESENT_UNKNOWN Key ErrorMsg 239 | REMOVE_SUCCESS Key 240 | REMOVE_FAILURE Key ErrorMsg 241 | COST Cost 242 | AVAILABILITY Availability 243 | INITREMOTE_SUCCESS 244 | INITREMOTE_FAILURE ErrorMsg 245 | CLAIMURL_SUCCESS 246 | CLAIMURL_FAILURE 247 | CHECKURL_CONTENTS Size FilePath 248 | CHECKURL_MULTI [(URLString, Size, FilePath)] 249 | CHECKURL_FAILURE ErrorMsg 250 | WHEREIS_SUCCESS String 251 | WHEREIS_FAILURE 252 | CONFIG Setting Description 253 | CONFIGEND 254 | INFOFIELD String 255 | INFOVALUE String 256 | INFOEND 257 | EXPORTSUPPORTED_SUCCESS 258 | EXPORTSUPPORTED_FAILURE 259 | REMOVEEXPORTDIRECTORY_SUCCESS 260 | REMOVEEXPORTDIRECTORY_FAILURE 261 | RENAMEEXPORT_SUCCESS Key 262 | RENAMEEXPORT_FAILURE Key 263 | UNSUPPORTED_REQUEST 264 deriving (Show) 265 266instance Proto.Receivable Response where 267 parseCommand "EXTENSIONS" = Proto.parse1 EXTENSIONS_RESPONSE 268 parseCommand "PREPARE-SUCCESS" = Proto.parse0 PREPARE_SUCCESS 269 parseCommand "PREPARE-FAILURE" = Proto.parse1 PREPARE_FAILURE 270 parseCommand "TRANSFER-SUCCESS" = Proto.parse2 TRANSFER_SUCCESS 271 parseCommand "TRANSFER-FAILURE" = Proto.parse3 TRANSFER_FAILURE 272 parseCommand "CHECKPRESENT-SUCCESS" = Proto.parse1 CHECKPRESENT_SUCCESS 273 parseCommand "CHECKPRESENT-FAILURE" = Proto.parse1 CHECKPRESENT_FAILURE 274 parseCommand "CHECKPRESENT-UNKNOWN" = Proto.parse2 CHECKPRESENT_UNKNOWN 275 parseCommand "REMOVE-SUCCESS" = Proto.parse1 REMOVE_SUCCESS 276 parseCommand "REMOVE-FAILURE" = Proto.parse2 REMOVE_FAILURE 277 parseCommand "COST" = Proto.parse1 COST 278 parseCommand "AVAILABILITY" = Proto.parse1 AVAILABILITY 279 parseCommand "INITREMOTE-SUCCESS" = Proto.parse0 INITREMOTE_SUCCESS 280 parseCommand "INITREMOTE-FAILURE" = Proto.parse1 INITREMOTE_FAILURE 281 parseCommand "CLAIMURL-SUCCESS" = Proto.parse0 CLAIMURL_SUCCESS 282 parseCommand "CLAIMURL-FAILURE" = Proto.parse0 CLAIMURL_FAILURE 283 parseCommand "CHECKURL-CONTENTS" = Proto.parse2 CHECKURL_CONTENTS 284 parseCommand "CHECKURL-MULTI" = Proto.parse1 CHECKURL_MULTI 285 parseCommand "CHECKURL-FAILURE" = Proto.parse1 CHECKURL_FAILURE 286 parseCommand "WHEREIS-SUCCESS" = Just . WHEREIS_SUCCESS 287 parseCommand "WHEREIS-FAILURE" = Proto.parse0 WHEREIS_FAILURE 288 parseCommand "CONFIG" = Proto.parse2 CONFIG 289 parseCommand "CONFIGEND" = Proto.parse0 CONFIGEND 290 parseCommand "INFOFIELD" = Proto.parse1 INFOFIELD 291 parseCommand "INFOVALUE" = Proto.parse1 INFOVALUE 292 parseCommand "INFOEND" = Proto.parse0 INFOEND 293 parseCommand "EXPORTSUPPORTED-SUCCESS" = Proto.parse0 EXPORTSUPPORTED_SUCCESS 294 parseCommand "EXPORTSUPPORTED-FAILURE" = Proto.parse0 EXPORTSUPPORTED_FAILURE 295 parseCommand "REMOVEEXPORTDIRECTORY-SUCCESS" = Proto.parse0 REMOVEEXPORTDIRECTORY_SUCCESS 296 parseCommand "REMOVEEXPORTDIRECTORY-FAILURE" = Proto.parse0 REMOVEEXPORTDIRECTORY_FAILURE 297 parseCommand "RENAMEEXPORT-SUCCESS" = Proto.parse1 RENAMEEXPORT_SUCCESS 298 parseCommand "RENAMEEXPORT-FAILURE" = Proto.parse1 RENAMEEXPORT_FAILURE 299 parseCommand "UNSUPPORTED-REQUEST" = Proto.parse0 UNSUPPORTED_REQUEST 300 parseCommand _ = Proto.parseFail 301 302-- Requests that the external remote can send at any time it's in control. 303data RemoteRequest 304 = VERSION ProtocolVersion 305 | PROGRESS BytesProcessed 306 | DIRHASH Key 307 | DIRHASH_LOWER Key 308 | SETCONFIG Setting String 309 | GETCONFIG Setting 310 | SETCREDS Setting String String 311 | GETCREDS Setting 312 | GETUUID 313 | GETGITDIR 314 | GETGITREMOTENAME 315 | SETWANTED PreferredContentExpression 316 | GETWANTED 317 | SETSTATE Key String 318 | GETSTATE Key 319 | SETURLPRESENT Key URLString 320 | SETURLMISSING Key URLString 321 | SETURIPRESENT Key URI 322 | SETURIMISSING Key URI 323 | GETURLS Key String 324 | DEBUG String 325 | INFO String 326 deriving (Show) 327 328instance Proto.Receivable RemoteRequest where 329 parseCommand "VERSION" = Proto.parse1 VERSION 330 parseCommand "PROGRESS" = Proto.parse1 PROGRESS 331 parseCommand "DIRHASH" = Proto.parse1 DIRHASH 332 parseCommand "DIRHASH-LOWER" = Proto.parse1 DIRHASH_LOWER 333 parseCommand "SETCONFIG" = Proto.parse2 SETCONFIG 334 parseCommand "GETCONFIG" = Proto.parse1 GETCONFIG 335 parseCommand "SETCREDS" = Proto.parse3 SETCREDS 336 parseCommand "GETCREDS" = Proto.parse1 GETCREDS 337 parseCommand "GETUUID" = Proto.parse0 GETUUID 338 parseCommand "GETGITDIR" = Proto.parse0 GETGITDIR 339 parseCommand "GETGITREMOTENAME" = Proto.parse0 GETGITREMOTENAME 340 parseCommand "SETWANTED" = Proto.parse1 SETWANTED 341 parseCommand "GETWANTED" = Proto.parse0 GETWANTED 342 parseCommand "SETSTATE" = Proto.parse2 SETSTATE 343 parseCommand "GETSTATE" = Proto.parse1 GETSTATE 344 parseCommand "SETURLPRESENT" = Proto.parse2 SETURLPRESENT 345 parseCommand "SETURLMISSING" = Proto.parse2 SETURLMISSING 346 parseCommand "SETURIPRESENT" = Proto.parse2 SETURIPRESENT 347 parseCommand "SETURIMISSING" = Proto.parse2 SETURIMISSING 348 parseCommand "GETURLS" = Proto.parse2 GETURLS 349 parseCommand "DEBUG" = Proto.parse1 DEBUG 350 parseCommand "INFO" = Proto.parse1 INFO 351 parseCommand _ = Proto.parseFail 352 353-- Responses to RemoteRequest. 354data RemoteResponse 355 = VALUE String 356 | CREDS String String 357 deriving (Show) 358 359instance Proto.Sendable RemoteResponse where 360 formatMessage (VALUE s) = [ "VALUE", Proto.serialize s ] 361 formatMessage (CREDS login password) = [ "CREDS", Proto.serialize login, Proto.serialize password ] 362 363-- Messages that can be sent at any time by either git-annex or the remote. 364data ExceptionalMessage 365 = ERROR ErrorMsg 366 deriving (Show) 367 368instance Proto.Sendable ExceptionalMessage where 369 formatMessage (ERROR err) = [ "ERROR", Proto.serialize err ] 370 371instance Proto.Receivable ExceptionalMessage where 372 parseCommand "ERROR" = Proto.parse1 ERROR 373 parseCommand _ = Proto.parseFail 374 375data AsyncMessage = AsyncMessage JobId WrappedMsg 376 377instance Proto.Receivable AsyncMessage where 378 parseCommand "J" = Proto.parse2 AsyncMessage 379 parseCommand _ = Proto.parseFail 380 381instance Proto.Sendable AsyncMessage where 382 formatMessage (AsyncMessage jid msg) = ["J", Proto.serialize jid, msg] 383 384data AsyncWrapped 385 = AsyncWrappedRemoteResponse RemoteResponse 386 | AsyncWrappedRequest Request 387 | AsyncWrappedExceptionalMessage ExceptionalMessage 388 | AsyncWrappedAsyncMessage AsyncMessage 389 390class ToAsyncWrapped t where 391 toAsyncWrapped :: t -> AsyncWrapped 392 393instance ToAsyncWrapped RemoteResponse where 394 toAsyncWrapped = AsyncWrappedRemoteResponse 395 396instance ToAsyncWrapped Request where 397 toAsyncWrapped = AsyncWrappedRequest 398 399instance ToAsyncWrapped ExceptionalMessage where 400 toAsyncWrapped = AsyncWrappedExceptionalMessage 401 402instance ToAsyncWrapped AsyncMessage where 403 toAsyncWrapped = AsyncWrappedAsyncMessage 404 405-- Data types used for parameters when communicating with the remote. 406-- All are serializable. 407type ErrorMsg = String 408type Setting = String 409type Description = String 410type ProtocolVersion = Int 411type Size = Maybe Integer 412type WrappedMsg = String 413newtype JobId = JobId Integer 414 deriving (Eq, Ord, Show) 415 416supportedProtocolVersions :: [ProtocolVersion] 417supportedProtocolVersions = [1] 418 419instance Proto.Serializable JobId where 420 serialize (JobId n) = show n 421 deserialize = JobId <$$> readMaybe 422 423instance Proto.Serializable Direction where 424 serialize Upload = "STORE" 425 serialize Download = "RETRIEVE" 426 427 deserialize "STORE" = Just Upload 428 deserialize "RETRIEVE" = Just Download 429 deserialize _ = Nothing 430 431instance Proto.Serializable ProtocolVersion where 432 serialize = show 433 deserialize = readish 434 435instance Proto.Serializable Cost where 436 serialize = show 437 deserialize = readish 438 439instance Proto.Serializable Size where 440 serialize (Just s) = show s 441 serialize Nothing = "UNKNOWN" 442 deserialize "UNKNOWN" = Just Nothing 443 deserialize s = maybe Nothing (Just . Just) (readish s) 444 445instance Proto.Serializable Availability where 446 serialize GloballyAvailable = "GLOBAL" 447 serialize LocallyAvailable = "LOCAL" 448 449 deserialize "GLOBAL" = Just GloballyAvailable 450 deserialize "LOCAL" = Just LocallyAvailable 451 deserialize _ = Nothing 452 453instance Proto.Serializable [(URLString, Size, FilePath)] where 454 serialize = unwords . map go 455 where 456 go (url, sz, f) = url ++ " " ++ maybe "UNKNOWN" show sz ++ " " ++ f 457 deserialize = Just . go [] . words 458 where 459 go c (url:sz:f:rest) = go ((url, readish sz, f):c) rest 460 go c _ = reverse c 461 462instance Proto.Serializable URI where 463 serialize = show 464 deserialize = parseURI 465 466instance Proto.Serializable ExportLocation where 467 serialize = fromRawFilePath . fromExportLocation 468 deserialize = Just . mkExportLocation . toRawFilePath 469 470instance Proto.Serializable ExportDirectory where 471 serialize = fromRawFilePath . fromExportDirectory 472 deserialize = Just . mkExportDirectory . toRawFilePath 473 474instance Proto.Serializable ExtensionList where 475 serialize (ExtensionList l) = unwords l 476 deserialize = Just . ExtensionList . words 477