04c12aa6df
Rather than using Read/Show, which would force me to preserve data types into the future. I considered just deriving json and sending that, but I don't much like deriving json with data types that have named constructors (like Key does) because again it locks in data type details. So instead, used SimpleProtocol, with a fairly complex and unreadable protocol. But it is as efficient as the p2p protocol at least, and as future proof. (Writing my own custom json instances would have worked but I thought of it too late and don't want to do all the work twice. The only real benefit might be that aeson could be faster.) Note that, when a new protocol request type is added later, git-annex trying to use it will cause the git-annex transferrer to display a protocol error message. That seems ok; it would only happen if a new git-annex found an old version of itself in PATH or the program file. So it's unlikely, and all it can do anyway is display an error. (The error message could perhaps be improved..) This commit was sponsored by Jack Hill on Patreon.
84 lines
2.2 KiB
Haskell
84 lines
2.2 KiB
Haskell
{- git-annex Messages data types
|
|
-
|
|
- Copyright 2012-2020 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
module Types.Messages where
|
|
|
|
import qualified Utility.Aeson as Aeson
|
|
import Utility.Metered
|
|
import Utility.FileSize
|
|
|
|
import Control.Concurrent
|
|
import System.Console.Regions (ConsoleRegion)
|
|
import qualified Data.ByteString as S
|
|
import qualified Data.ByteString.Lazy as L
|
|
|
|
data OutputType
|
|
= NormalOutput
|
|
| QuietOutput
|
|
| JSONOutput JSONOptions
|
|
| SerializedOutput
|
|
(SerializedOutput -> IO ())
|
|
(IO (Maybe SerializedOutputResponse))
|
|
|
|
data JSONOptions = JSONOptions
|
|
{ jsonProgress :: Bool
|
|
, jsonErrorMessages :: Bool
|
|
}
|
|
deriving (Show)
|
|
|
|
adjustOutputType :: OutputType -> OutputType -> OutputType
|
|
adjustOutputType (JSONOutput old) (JSONOutput new) = JSONOutput $ JSONOptions
|
|
{ jsonProgress = jsonProgress old || jsonProgress new
|
|
, jsonErrorMessages = jsonErrorMessages old || jsonErrorMessages new
|
|
}
|
|
adjustOutputType _old new = new
|
|
|
|
data SideActionBlock = NoBlock | StartBlock | InBlock
|
|
deriving (Eq)
|
|
|
|
data MessageState = MessageState
|
|
{ outputType :: OutputType
|
|
, concurrentOutputEnabled :: Bool
|
|
, sideActionBlock :: SideActionBlock
|
|
, consoleRegion :: Maybe ConsoleRegion
|
|
, consoleRegionErrFlag :: Bool
|
|
, jsonBuffer :: Maybe Aeson.Object
|
|
, promptLock :: MVar () -- left full when not prompting
|
|
}
|
|
|
|
newMessageState :: IO MessageState
|
|
newMessageState = do
|
|
promptlock <- newMVar ()
|
|
return $ MessageState
|
|
{ outputType = NormalOutput
|
|
, concurrentOutputEnabled = False
|
|
, sideActionBlock = NoBlock
|
|
, consoleRegion = Nothing
|
|
, consoleRegionErrFlag = False
|
|
, jsonBuffer = Nothing
|
|
, promptLock = promptlock
|
|
}
|
|
|
|
-- | When communicating with a child process over a pipe while it is
|
|
-- performing some action, this is used to pass back output that the child
|
|
-- would normally display to the console.
|
|
data SerializedOutput
|
|
= OutputMessage S.ByteString
|
|
| OutputError String
|
|
| StartProgressMeter (Maybe FileSize)
|
|
| UpdateProgressMeter BytesProcessed
|
|
| EndProgressMeter
|
|
| StartPrompt
|
|
| EndPrompt
|
|
| JSONObject L.ByteString
|
|
-- ^ This is always sent, it's up to the consumer to decide if it
|
|
-- wants to display JSON, or human-readable messages.
|
|
deriving (Show)
|
|
|
|
data SerializedOutputResponse
|
|
= ReadyPrompt
|
|
deriving (Eq, Show)
|