89e1a05a8f
As long as all code imports Utility.Aeson rather than Data.Aeson, and no Strings that may contain utf-8 characters are used for eg, object keys via T.pack, this is guaranteed to fix the problem everywhere that git-annex generates json. It's kind of annoying to need to wrap ToJSON with a ToJSON', especially since every data type that has a ToJSON instance has to be ported over. However, that only took 50 lines of code, which is worth it to ensure full coverage. I initially tried an alternative approach of a newtype FileEncoded, which had to be used everywhere a String was fed into aeson, and chasing down all the sites would have been far too hard. Did consider creating an intentionally overlapping instance ToJSON String, and letting ghc fail to build anything that passed in a String, but am not sure that wouldn't pollute some library that git-annex depends on that happens to use ToJSON String internally. This commit was supported by the NSF-funded DataLad project.
65 lines
1.6 KiB
Haskell
65 lines
1.6 KiB
Haskell
{- git-annex Messages data types
|
|
-
|
|
- Copyright 2012-2018 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
module Types.Messages where
|
|
|
|
import qualified Utility.Aeson as Aeson
|
|
|
|
import Control.Concurrent
|
|
#ifdef WITH_CONCURRENTOUTPUT
|
|
import System.Console.Regions (ConsoleRegion)
|
|
#endif
|
|
|
|
data OutputType = NormalOutput | QuietOutput | JSONOutput JSONOptions
|
|
deriving (Show)
|
|
|
|
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
|
|
, implicitMessages :: Bool
|
|
#ifdef WITH_CONCURRENTOUTPUT
|
|
, consoleRegion :: Maybe ConsoleRegion
|
|
, consoleRegionErrFlag :: Bool
|
|
#endif
|
|
, 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
|
|
, implicitMessages = True
|
|
#ifdef WITH_CONCURRENTOUTPUT
|
|
, consoleRegion = Nothing
|
|
, consoleRegionErrFlag = False
|
|
#endif
|
|
, jsonBuffer = Nothing
|
|
, promptLock = promptlock
|
|
}
|