2020-07-29 19:23:18 +00:00
|
|
|
{- git-annex external backend
|
|
|
|
-
|
|
|
|
- Copyright 2020 Joey Hess <id@joeyh.name>
|
|
|
|
-
|
|
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
|
|
-}
|
|
|
|
|
|
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
2021-04-05 17:40:31 +00:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
2020-07-29 19:23:18 +00:00
|
|
|
|
|
|
|
module Backend.External (makeBackend) where
|
|
|
|
|
|
|
|
import Annex.Common
|
|
|
|
import Annex.ExternalAddonProcess
|
2020-07-29 21:12:22 +00:00
|
|
|
import Backend.Utilities
|
2020-07-29 19:23:18 +00:00
|
|
|
import Types.Key
|
|
|
|
import Types.Backend
|
|
|
|
import Types.KeySource
|
|
|
|
import Utility.Metered
|
|
|
|
import qualified Utility.SimpleProtocol as Proto
|
|
|
|
|
|
|
|
import qualified Data.ByteString as S
|
2021-10-06 00:20:08 +00:00
|
|
|
import qualified Data.ByteString.Short as S (toShort, fromShort)
|
2020-07-29 19:23:18 +00:00
|
|
|
import qualified Data.Map.Strict as M
|
2020-07-29 21:12:22 +00:00
|
|
|
import Data.Char
|
2020-07-29 19:23:18 +00:00
|
|
|
import Control.Concurrent
|
|
|
|
import System.IO.Unsafe (unsafePerformIO)
|
|
|
|
|
|
|
|
newtype ExternalBackendName = ExternalBackendName S.ByteString
|
|
|
|
deriving (Show, Eq, Ord)
|
|
|
|
|
|
|
|
-- Makes Backend representing an external backend of any type.
|
|
|
|
-- If the program is not available or doesn't work, makes a Backend
|
|
|
|
-- that cannot generate or verify keys, but that still lets the keys be
|
|
|
|
-- basically used.
|
|
|
|
makeBackend :: S.ByteString -> HasExt -> Annex Backend
|
2020-07-29 20:35:14 +00:00
|
|
|
makeBackend bname hasext =
|
|
|
|
withExternalState ebname hasext (return . externalBackend)
|
2020-07-29 19:23:18 +00:00
|
|
|
where
|
|
|
|
ebname = ExternalBackendName bname
|
2020-07-29 20:35:14 +00:00
|
|
|
|
|
|
|
makeBackend' :: ExternalBackendName -> HasExt -> Either ExternalAddonStartError ExternalAddonProcess -> Annex Backend
|
|
|
|
makeBackend' ebname@(ExternalBackendName bname) hasext (Right p) = do
|
|
|
|
let st = ExternalState
|
|
|
|
{ externalAddonProcess = Right p
|
|
|
|
, externalBackend = unavailBackend ebname hasext
|
|
|
|
}
|
|
|
|
canverify <- handleRequest st CANVERIFY (pure False) $ \case
|
|
|
|
CANVERIFY_YES -> result True
|
|
|
|
CANVERIFY_NO -> result False
|
|
|
|
_ -> Nothing
|
|
|
|
isstable <- handleRequest st ISSTABLE (pure False) $ \case
|
|
|
|
ISSTABLE_YES -> result True
|
|
|
|
ISSTABLE_NO -> result False
|
|
|
|
_ -> Nothing
|
|
|
|
iscryptographicallysecure <- handleRequest st ISCRYPTOGRAPHICALLYSECURE (pure False) $ \case
|
|
|
|
ISCRYPTOGRAPHICALLYSECURE_YES -> result True
|
|
|
|
ISCRYPTOGRAPHICALLYSECURE_NO -> result False
|
|
|
|
_ -> Nothing
|
|
|
|
return $ Backend
|
|
|
|
{ backendVariety = ExternalKey bname hasext
|
|
|
|
, genKey = Just $ genKeyExternal ebname hasext
|
|
|
|
, verifyKeyContent = if canverify
|
|
|
|
then Just $ verifyKeyContentExternal ebname hasext
|
|
|
|
-- The protocol supports PROGRESS here,
|
|
|
|
-- but it's not actually used. It was put
|
|
|
|
-- in to avoid needing a protocol version
|
|
|
|
-- bump if progress handling is later added.
|
|
|
|
nullMeterUpdate
|
|
|
|
else Nothing
|
2021-02-09 19:00:51 +00:00
|
|
|
, verifyKeyContentIncrementally = Nothing
|
2020-07-29 20:35:14 +00:00
|
|
|
, canUpgradeKey = Nothing
|
|
|
|
, fastMigrate = Nothing
|
|
|
|
, isStableKey = const isstable
|
2024-02-29 21:21:29 +00:00
|
|
|
, isCryptographicallySecure = iscryptographicallysecure
|
|
|
|
, isCryptographicallySecureKey = const (pure iscryptographicallysecure)
|
2020-07-29 20:35:14 +00:00
|
|
|
}
|
|
|
|
makeBackend' ebname hasext (Left _) = return $ unavailBackend ebname hasext
|
|
|
|
|
|
|
|
unavailBackend :: ExternalBackendName -> HasExt -> Backend
|
|
|
|
unavailBackend (ExternalBackendName bname) hasext =
|
|
|
|
Backend
|
2020-07-29 19:23:18 +00:00
|
|
|
{ backendVariety = ExternalKey bname hasext
|
|
|
|
, genKey = Nothing
|
|
|
|
, verifyKeyContent = Nothing
|
2021-02-09 19:00:51 +00:00
|
|
|
, verifyKeyContentIncrementally = Nothing
|
2020-07-29 19:23:18 +00:00
|
|
|
, canUpgradeKey = Nothing
|
|
|
|
, fastMigrate = Nothing
|
|
|
|
, isStableKey = const False
|
2024-02-29 21:21:29 +00:00
|
|
|
, isCryptographicallySecure = False
|
|
|
|
, isCryptographicallySecureKey = const (pure False)
|
2020-07-29 19:23:18 +00:00
|
|
|
}
|
|
|
|
|
2020-07-29 20:35:14 +00:00
|
|
|
genKeyExternal :: ExternalBackendName -> HasExt -> KeySource -> MeterUpdate -> Annex Key
|
|
|
|
genKeyExternal ebname hasext ks meterupdate =
|
|
|
|
withExternalState ebname hasext $ \st ->
|
|
|
|
handleRequest st req notavail go
|
|
|
|
where
|
|
|
|
req = GENKEY (fromRawFilePath (contentLocation ks))
|
|
|
|
notavail = giveup $ "Cannot generate a key, since " ++ externalBackendProgram ebname ++ " is not available."
|
|
|
|
|
2020-07-29 21:12:22 +00:00
|
|
|
go (GENKEY_SUCCESS pk) = Just $ Result <$> fromProtoKey pk hasext ks
|
2020-07-29 20:35:14 +00:00
|
|
|
go (GENKEY_FAILURE msg) = Just $ giveup $
|
|
|
|
"External backend program failed to generate a key: " ++ msg
|
|
|
|
go (PROGRESS bytesprocessed) = Just $ do
|
|
|
|
liftIO $ meterupdate bytesprocessed
|
|
|
|
return $ GetNextMessage go
|
|
|
|
go _ = Nothing
|
|
|
|
|
2020-11-05 15:26:34 +00:00
|
|
|
verifyKeyContentExternal :: ExternalBackendName -> HasExt -> MeterUpdate -> Key -> RawFilePath -> Annex Bool
|
2020-07-29 20:35:14 +00:00
|
|
|
verifyKeyContentExternal ebname hasext meterupdate k f =
|
|
|
|
withExternalState ebname hasext $ \st ->
|
|
|
|
handleRequest st req notavail go
|
|
|
|
where
|
2020-11-05 15:26:34 +00:00
|
|
|
req = VERIFYKEYCONTENT (toProtoKey k) (fromRawFilePath f)
|
2020-07-29 20:35:14 +00:00
|
|
|
|
|
|
|
-- This should not be able to happen, because CANVERIFY is checked
|
|
|
|
-- before this function is enable, and so the external program
|
|
|
|
-- is available. But if it does, fail the verification.
|
|
|
|
notavail = return False
|
2020-07-29 19:23:18 +00:00
|
|
|
|
2020-07-29 20:35:14 +00:00
|
|
|
go VERIFYKEYCONTENT_SUCCESS = result True
|
|
|
|
go VERIFYKEYCONTENT_FAILURE = result False
|
|
|
|
go (PROGRESS bytesprocessed) = Just $ do
|
|
|
|
liftIO $ meterupdate bytesprocessed
|
|
|
|
return $ GetNextMessage go
|
|
|
|
go _ = Nothing
|
2020-07-29 19:23:18 +00:00
|
|
|
|
|
|
|
-- State about a running external backend program.
|
|
|
|
data ExternalState = ExternalState
|
|
|
|
{ externalAddonProcess :: Either ExternalAddonStartError ExternalAddonProcess
|
2020-07-29 20:35:14 +00:00
|
|
|
, externalBackend :: Backend
|
2020-07-29 19:23:18 +00:00
|
|
|
}
|
|
|
|
|
|
|
|
handleRequest :: ExternalState -> Request -> Annex a -> ResponseHandler a -> Annex a
|
|
|
|
handleRequest st req whenunavail responsehandler =
|
|
|
|
withExternalAddon st whenunavail $ \p -> do
|
|
|
|
sendMessage p req
|
2020-07-29 20:35:14 +00:00
|
|
|
let loop = receiveResponse p responsehandler
|
2020-08-12 16:04:12 +00:00
|
|
|
(Just . handleExceptionalMessage loop)
|
2020-07-29 20:35:14 +00:00
|
|
|
loop
|
2020-07-29 19:23:18 +00:00
|
|
|
where
|
2020-08-12 16:04:12 +00:00
|
|
|
handleExceptionalMessage _ (ERROR err) = do
|
filter out control characters in warning messages
Converted warning and similar to use StringContainingQuotedPath. Most
warnings are static strings, some do refer to filepaths that need to be
quoted, and others don't need quoting.
Note that, since quote filters out control characters of even
UnquotedString, this makes all warnings safe, even when an attacker
sneaks in a control character in some other way.
When json is being output, no quoting is done, since json gets its own
quoting.
This does, as a side effect, make warning messages in json output not
be indented. The indentation is only needed to offset warning messages
underneath the display of the file they apply to, so that's ok.
Sponsored-by: Brett Eisenberg on Patreon
2023-04-10 18:47:32 +00:00
|
|
|
warning $ UnquotedString $
|
|
|
|
"external special remote error: " ++ err
|
2020-07-29 19:23:18 +00:00
|
|
|
whenunavail
|
2020-08-12 16:04:12 +00:00
|
|
|
handleExceptionalMessage loop (DEBUG msg) = do
|
2021-04-06 19:41:24 +00:00
|
|
|
fastDebug "Backend.External" msg
|
2020-07-29 20:35:14 +00:00
|
|
|
loop
|
2020-07-29 19:23:18 +00:00
|
|
|
|
|
|
|
withExternalAddon :: ExternalState -> a -> (ExternalAddonProcess -> a) -> a
|
|
|
|
withExternalAddon st whenunavail a = case externalAddonProcess st of
|
|
|
|
Right addon -> a addon
|
|
|
|
Left _ -> whenunavail
|
|
|
|
|
|
|
|
sendMessage :: Proto.Sendable m => ExternalAddonProcess -> m -> Annex ()
|
|
|
|
sendMessage p m = liftIO $ do
|
|
|
|
protocolDebug p True line
|
|
|
|
hPutStrLn (externalSend p) line
|
|
|
|
hFlush (externalSend p)
|
|
|
|
where
|
|
|
|
line = unwords $ Proto.formatMessage m
|
|
|
|
|
2023-03-14 02:39:16 +00:00
|
|
|
{- A response handler can yield a result, or it can request that another
|
2020-07-29 19:23:18 +00:00
|
|
|
- message be consumed from the external. -}
|
|
|
|
data ResponseHandlerResult a
|
|
|
|
= Result a
|
|
|
|
| GetNextMessage (ResponseHandler a)
|
|
|
|
|
|
|
|
type ResponseHandler a = Response -> Maybe (Annex (ResponseHandlerResult a))
|
|
|
|
|
|
|
|
result :: a -> Maybe (Annex (ResponseHandlerResult a))
|
|
|
|
result = Just . return . Result
|
|
|
|
|
|
|
|
{- Waits for a message from the external backend, and passes it to the
|
2023-03-14 02:39:16 +00:00
|
|
|
- appropriate handler.
|
2020-07-29 19:23:18 +00:00
|
|
|
-
|
|
|
|
- If the handler returns Nothing, this is a protocol error.
|
|
|
|
-}
|
|
|
|
receiveResponse
|
|
|
|
:: ExternalAddonProcess
|
|
|
|
-> ResponseHandler a
|
2020-08-12 16:04:12 +00:00
|
|
|
-> (ExceptionalMessage -> Maybe (Annex a))
|
2020-07-29 19:23:18 +00:00
|
|
|
-> Annex a
|
2020-08-12 16:04:12 +00:00
|
|
|
receiveResponse p handleresponse handleexceptional =
|
2020-07-29 19:23:18 +00:00
|
|
|
go =<< liftIO (catchMaybeIO $ hGetLine $ externalReceive p)
|
|
|
|
where
|
|
|
|
go Nothing = protocolError False ""
|
|
|
|
go (Just s) = do
|
|
|
|
liftIO $ protocolDebug p False s
|
|
|
|
case Proto.parseMessage s :: Maybe Response of
|
|
|
|
Just resp -> case handleresponse resp of
|
|
|
|
Nothing -> protocolError True s
|
|
|
|
Just callback -> callback >>= \case
|
|
|
|
Result a -> return a
|
|
|
|
GetNextMessage handleresponse' ->
|
2020-08-12 16:04:12 +00:00
|
|
|
receiveResponse p handleresponse' handleexceptional
|
|
|
|
Nothing -> case Proto.parseMessage s :: Maybe ExceptionalMessage of
|
|
|
|
Just msg -> maybe (protocolError True s) id (handleexceptional msg)
|
2020-07-29 19:23:18 +00:00
|
|
|
Nothing -> protocolError False s
|
|
|
|
|
|
|
|
protocolError parsed s = giveup $ "external backend protocol error, unexpectedly received \"" ++ s ++ "\" " ++
|
|
|
|
if parsed
|
|
|
|
then "(message not allowed at this time)"
|
|
|
|
else "(unable to parse message)"
|
|
|
|
|
|
|
|
-- Information about pools of of running external backends that are
|
|
|
|
-- available to use is stored in this global.
|
|
|
|
{-# NOINLINE poolVar #-}
|
|
|
|
poolVar :: MVar (M.Map ExternalBackendName (ExternalAddonPID, [ExternalState]))
|
|
|
|
poolVar = unsafePerformIO $ newMVar M.empty
|
|
|
|
|
|
|
|
-- Starts a new instance of an external backend.
|
|
|
|
-- Does not add it to the poolVar; caller should add it once it's done
|
|
|
|
-- using it.
|
2020-07-29 20:35:14 +00:00
|
|
|
newExternalState :: ExternalBackendName -> HasExt -> ExternalAddonPID -> Annex ExternalState
|
|
|
|
newExternalState ebname hasext pid = do
|
2020-07-29 19:23:18 +00:00
|
|
|
st <- startExternalAddonProcess basecmd pid
|
|
|
|
st' <- case st of
|
|
|
|
Left (ProgramNotInstalled msg) -> warnonce msg >> return st
|
|
|
|
Left (ProgramFailure msg) -> warnonce msg >> return st
|
|
|
|
Right p -> do
|
|
|
|
sendMessage p GETVERSION
|
|
|
|
v <- receiveResponse p
|
|
|
|
(\resp -> case resp of
|
|
|
|
VERSION v -> result v
|
|
|
|
_ -> Nothing
|
|
|
|
)
|
|
|
|
(const Nothing)
|
|
|
|
if v `notElem` supportedProtocolVersions
|
|
|
|
then do
|
|
|
|
warnonce (basecmd ++ " uses an unsupported version of the external backend protocol")
|
|
|
|
return $ Left (ProgramFailure "bad protocol version")
|
|
|
|
else return (Right p)
|
2020-07-29 20:35:14 +00:00
|
|
|
backend <- makeBackend' ebname hasext st'
|
|
|
|
return $ ExternalState
|
|
|
|
{ externalAddonProcess = st'
|
|
|
|
, externalBackend = backend
|
|
|
|
}
|
2020-07-29 19:23:18 +00:00
|
|
|
where
|
2020-07-29 20:35:14 +00:00
|
|
|
basecmd = externalBackendProgram ebname
|
2020-07-29 19:23:18 +00:00
|
|
|
warnonce msg = when (pid == 1) $
|
filter out control characters in warning messages
Converted warning and similar to use StringContainingQuotedPath. Most
warnings are static strings, some do refer to filepaths that need to be
quoted, and others don't need quoting.
Note that, since quote filters out control characters of even
UnquotedString, this makes all warnings safe, even when an attacker
sneaks in a control character in some other way.
When json is being output, no quoting is done, since json gets its own
quoting.
This does, as a side effect, make warning messages in json output not
be indented. The indentation is only needed to offset warning messages
underneath the display of the file they apply to, so that's ok.
Sponsored-by: Brett Eisenberg on Patreon
2023-04-10 18:47:32 +00:00
|
|
|
warning (UnquotedString msg)
|
2020-07-29 19:23:18 +00:00
|
|
|
|
2020-07-29 20:35:14 +00:00
|
|
|
externalBackendProgram :: ExternalBackendName -> String
|
2021-08-11 00:45:02 +00:00
|
|
|
externalBackendProgram (ExternalBackendName bname) = "git-annex-backend-X" ++ decodeBS bname
|
2020-07-29 20:35:14 +00:00
|
|
|
|
2020-07-29 19:23:18 +00:00
|
|
|
-- Runs an action with an ExternalState, starting a new external backend
|
|
|
|
-- process if necessary. It is returned to the pool once the action
|
|
|
|
-- finishes successfully. On exception, it's shut down.
|
2020-07-29 20:35:14 +00:00
|
|
|
withExternalState :: ExternalBackendName -> HasExt -> (ExternalState -> Annex a) -> Annex a
|
|
|
|
withExternalState bname hasext a = do
|
2020-07-29 19:23:18 +00:00
|
|
|
st <- get
|
|
|
|
r <- a st `onException` shutdown st
|
|
|
|
put st -- only when no exception is thrown
|
|
|
|
return r
|
|
|
|
where
|
|
|
|
get = do
|
|
|
|
m <- liftIO $ takeMVar poolVar
|
|
|
|
case fromMaybe (1, []) (M.lookup bname m) of
|
|
|
|
(pid, []) -> do
|
|
|
|
let m' = M.insert bname (succ pid, []) m
|
|
|
|
liftIO $ putMVar poolVar m'
|
2020-07-29 20:35:14 +00:00
|
|
|
newExternalState bname hasext pid
|
2020-07-29 19:23:18 +00:00
|
|
|
(pid, (st:rest)) -> do
|
|
|
|
let m' = M.insert bname (pid, rest) m
|
|
|
|
liftIO $ putMVar poolVar m'
|
|
|
|
return st
|
|
|
|
put st = liftIO $ modifyMVar_ poolVar $
|
|
|
|
pure . M.adjust (\(pid, l) -> (pid, st:l)) bname
|
|
|
|
shutdown st = liftIO $
|
|
|
|
withExternalAddon st noop (flip externalShutdown False)
|
|
|
|
|
|
|
|
-- This is a key as seen by the protocol consumer. When the "E" variant
|
|
|
|
-- of the external backend is in use, it does not include an extension.
|
|
|
|
-- And it's assumed not to contain spaces or newlines, or anything besides
|
|
|
|
-- ascii alphanumerics, because the protocol does not allow keys containing
|
|
|
|
-- such things.
|
|
|
|
newtype ProtoKey = ProtoKey Key
|
|
|
|
deriving (Show)
|
|
|
|
|
2020-07-29 21:12:22 +00:00
|
|
|
fromProtoKey :: ProtoKey -> HasExt -> KeySource -> Annex Key
|
|
|
|
fromProtoKey (ProtoKey k) (HasExt False) _ = pure k
|
|
|
|
fromProtoKey (ProtoKey k) hasext@(HasExt True) source =
|
|
|
|
addE source (setHasExt hasext) k
|
|
|
|
|
|
|
|
toProtoKey :: Key -> ProtoKey
|
|
|
|
toProtoKey k = ProtoKey $ alterKey k $ \d -> d
|
|
|
|
-- The extension can be easily removed, because the protocol
|
|
|
|
-- documentation does not allow '.' to be used in the keyName,
|
|
|
|
-- so the first one is the extension.
|
2021-10-06 00:20:08 +00:00
|
|
|
{ keyName = S.toShort (S.takeWhile (/= dot) (S.fromShort (keyName d)))
|
2020-07-29 21:12:22 +00:00
|
|
|
, keyVariety = setHasExt (HasExt False) (keyVariety d)
|
|
|
|
}
|
|
|
|
where
|
|
|
|
dot = fromIntegral (ord '.')
|
|
|
|
|
|
|
|
setHasExt :: HasExt -> KeyVariety -> KeyVariety
|
|
|
|
setHasExt hasext (ExternalKey name _) = ExternalKey name hasext
|
|
|
|
setHasExt _ v = v
|
|
|
|
|
2020-07-29 19:23:18 +00:00
|
|
|
instance Proto.Serializable ProtoKey where
|
|
|
|
serialize (ProtoKey k) = Proto.serialize k
|
|
|
|
deserialize = fmap ProtoKey . Proto.deserialize
|
|
|
|
|
|
|
|
data Request
|
|
|
|
= GETVERSION
|
|
|
|
| CANVERIFY
|
|
|
|
| ISSTABLE
|
|
|
|
| ISCRYPTOGRAPHICALLYSECURE
|
|
|
|
| GENKEY FilePath
|
|
|
|
| VERIFYKEYCONTENT ProtoKey FilePath
|
|
|
|
deriving (Show)
|
|
|
|
|
|
|
|
data Response
|
|
|
|
= VERSION ProtocolVersion
|
|
|
|
| CANVERIFY_YES
|
|
|
|
| CANVERIFY_NO
|
|
|
|
| ISSTABLE_YES
|
|
|
|
| ISSTABLE_NO
|
|
|
|
| ISCRYPTOGRAPHICALLYSECURE_YES
|
|
|
|
| ISCRYPTOGRAPHICALLYSECURE_NO
|
|
|
|
| GENKEY_SUCCESS ProtoKey
|
|
|
|
| GENKEY_FAILURE ErrorMsg
|
|
|
|
| VERIFYKEYCONTENT_SUCCESS
|
|
|
|
| VERIFYKEYCONTENT_FAILURE
|
|
|
|
| PROGRESS BytesProcessed
|
|
|
|
deriving (Show)
|
|
|
|
|
2020-08-12 16:04:12 +00:00
|
|
|
data ExceptionalMessage
|
2020-07-29 19:23:18 +00:00
|
|
|
= ERROR ErrorMsg
|
2020-07-29 20:35:14 +00:00
|
|
|
| DEBUG String
|
2020-07-29 19:23:18 +00:00
|
|
|
deriving (Show)
|
|
|
|
|
|
|
|
type ErrorMsg = String
|
|
|
|
|
|
|
|
newtype ProtocolVersion = ProtocolVersion Int
|
|
|
|
deriving (Show, Eq)
|
|
|
|
|
|
|
|
supportedProtocolVersions :: [ProtocolVersion]
|
|
|
|
supportedProtocolVersions = [ProtocolVersion 1]
|
|
|
|
|
|
|
|
instance Proto.Serializable ProtocolVersion where
|
|
|
|
serialize (ProtocolVersion n) = show n
|
|
|
|
deserialize = ProtocolVersion <$$> readish
|
|
|
|
|
2020-08-12 16:04:12 +00:00
|
|
|
instance Proto.Sendable ExceptionalMessage where
|
2020-07-29 20:35:14 +00:00
|
|
|
formatMessage (ERROR err) = ["ERROR", Proto.serialize err]
|
|
|
|
formatMessage (DEBUG msg) = ["DEBUG", Proto.serialize msg]
|
2020-07-29 19:23:18 +00:00
|
|
|
|
2020-08-12 16:04:12 +00:00
|
|
|
instance Proto.Receivable ExceptionalMessage where
|
2020-07-29 19:23:18 +00:00
|
|
|
parseCommand "ERROR" = Proto.parse1 ERROR
|
2020-07-29 20:35:14 +00:00
|
|
|
parseCommand "DEBUG" = Proto.parse1 DEBUG
|
2020-07-29 19:23:18 +00:00
|
|
|
parseCommand _ = Proto.parseFail
|
|
|
|
|
|
|
|
instance Proto.Sendable Request where
|
|
|
|
formatMessage GETVERSION = ["GETVERSION"]
|
|
|
|
formatMessage CANVERIFY = ["CANVERIFY"]
|
|
|
|
formatMessage ISSTABLE = ["ISSTABLE"]
|
|
|
|
formatMessage ISCRYPTOGRAPHICALLYSECURE = ["ISCRYPTOGRAPHICALLYSECURE"]
|
|
|
|
formatMessage (GENKEY file) = ["GENKEY", Proto.serialize file]
|
|
|
|
formatMessage (VERIFYKEYCONTENT key file) =
|
|
|
|
["VERIFYKEYCONTENT", Proto.serialize key, Proto.serialize file]
|
|
|
|
|
|
|
|
instance Proto.Receivable Response where
|
|
|
|
parseCommand "VERSION" = Proto.parse1 VERSION
|
|
|
|
parseCommand "CANVERIFY-YES" = Proto.parse0 CANVERIFY_YES
|
|
|
|
parseCommand "CANVERIFY-NO" = Proto.parse0 CANVERIFY_NO
|
|
|
|
parseCommand "ISSTABLE-YES" = Proto.parse0 ISSTABLE_YES
|
|
|
|
parseCommand "ISSTABLE-NO" = Proto.parse0 ISSTABLE_NO
|
|
|
|
parseCommand "ISCRYPTOGRAPHICALLYSECURE-YES" = Proto.parse0 ISCRYPTOGRAPHICALLYSECURE_YES
|
|
|
|
parseCommand "ISCRYPTOGRAPHICALLYSECURE-NO" = Proto.parse0 ISCRYPTOGRAPHICALLYSECURE_NO
|
|
|
|
parseCommand "GENKEY-SUCCESS" = Proto.parse1 GENKEY_SUCCESS
|
|
|
|
parseCommand "GENKEY-FAILURE" = Proto.parse1 GENKEY_FAILURE
|
|
|
|
parseCommand "VERIFYKEYCONTENT-SUCCESS" = Proto.parse0 VERIFYKEYCONTENT_SUCCESS
|
|
|
|
parseCommand "VERIFYKEYCONTENT-FAILURE" = Proto.parse0 VERIFYKEYCONTENT_FAILURE
|
|
|
|
parseCommand "PROGRESS" = Proto.parse1 PROGRESS
|
|
|
|
parseCommand _ = Proto.parseFail
|