-- | Hackage-specific wrappers around the Util.JSON module
{-# LANGUAGE CPP #-}
module Hackage.Security.JSON (
    -- * Deserialization errors
    DeserializationError(..)
  , validate
  , verifyType
    -- * MonadKeys
  , MonadKeys(..)
  , addKeys
  , withKeys
  , lookupKey
  , readKeyAsId
    -- * Reader monads
  , ReadJSON_Keys_Layout
  , ReadJSON_Keys_NoLayout
  , ReadJSON_NoKeys_NoLayout
  , runReadJSON_Keys_Layout
  , runReadJSON_Keys_NoLayout
  , runReadJSON_NoKeys_NoLayout
    -- ** Utility
  , parseJSON_Keys_Layout
  , parseJSON_Keys_NoLayout
  , parseJSON_NoKeys_NoLayout
  , readJSON_Keys_Layout
  , readJSON_Keys_NoLayout
  , readJSON_NoKeys_NoLayout
    -- * Writing
  , WriteJSON
  , runWriteJSON
    -- ** Utility
  , renderJSON
  , renderJSON_NoLayout
  , writeJSON
  , writeJSON_NoLayout
  , writeKeyAsId
    -- * Re-exports
  , module Hackage.Security.Util.JSON
  ) where

import MyPrelude
import Control.Arrow (first, second)
import Control.Exception
import Control.Monad (unless, liftM)
import Control.Monad.Except (MonadError, Except, ExceptT, runExcept, runExceptT, throwError)
import Control.Monad.Reader (MonadReader, Reader, runReader, local, ask)
import Data.Functor.Identity
import Data.Typeable (Typeable)
import qualified Data.ByteString.Lazy as BS.L

import Hackage.Security.Key
import Hackage.Security.Key.Env (KeyEnv)
import Hackage.Security.TUF.Layout.Repo
import Hackage.Security.Util.JSON
import Hackage.Security.Util.Path
import Hackage.Security.Util.Pretty
import Hackage.Security.Util.Some
import Text.JSON.Canonical
import qualified Hackage.Security.Key.Env as KeyEnv

{-------------------------------------------------------------------------------
  Deserialization errors
-------------------------------------------------------------------------------}

data DeserializationError =
    -- | Malformed JSON has syntax errors in the JSON itself
    -- (i.e., we cannot even parse it to a JSValue)
    DeserializationErrorMalformed String

    -- | Invalid JSON has valid syntax but invalid structure
    --
    -- The string gives a hint about what we expected instead
  | DeserializationErrorSchema String

    -- | The JSON file contains a key ID of an unknown key
  | DeserializationErrorUnknownKey KeyId

    -- | Some verification step failed
  | DeserializationErrorValidation String

    -- | Wrong file type
    --
    -- Records actual and expected types.
  | DeserializationErrorFileType String String
  deriving (Typeable)

#if MIN_VERSION_base(4,8,0)
deriving instance Show DeserializationError
instance Exception DeserializationError where displayException :: DeserializationError -> String
displayException = forall a. Pretty a => a -> String
pretty
#else
instance Show DeserializationError where show = pretty
instance Exception DeserializationError
#endif

instance Pretty DeserializationError where
  pretty :: DeserializationError -> String
pretty (DeserializationErrorMalformed String
str) =
      String
"Malformed: " forall a. [a] -> [a] -> [a]
++ String
str
  pretty (DeserializationErrorSchema String
str) =
      String
"Schema error: " forall a. [a] -> [a] -> [a]
++ String
str
  pretty (DeserializationErrorUnknownKey KeyId
kId) =
      String
"Unknown key: " forall a. [a] -> [a] -> [a]
++ KeyId -> String
keyIdString KeyId
kId
  pretty (DeserializationErrorValidation String
str) =
      String
"Invalid: " forall a. [a] -> [a] -> [a]
++ String
str
  pretty (DeserializationErrorFileType String
actualType String
expectedType) =
         String
"Expected file of type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
expectedType
      forall a. [a] -> [a] -> [a]
++ String
" but got file of type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
actualType

validate :: MonadError DeserializationError m => String -> Bool -> m ()
validate :: forall (m :: * -> *).
MonadError DeserializationError m =>
String -> Bool -> m ()
validate String
_   Bool
True  = forall (m :: * -> *) a. Monad m => a -> m a
return ()
validate String
msg Bool
False = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> DeserializationError
DeserializationErrorValidation String
msg

verifyType :: (ReportSchemaErrors m, MonadError DeserializationError m)
           => JSValue -> String -> m ()
verifyType :: forall (m :: * -> *).
(ReportSchemaErrors m, MonadError DeserializationError m) =>
JSValue -> String -> m ()
verifyType JSValue
enc String
expectedType = do
    String
actualType <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"_type"
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String
actualType forall a. Eq a => a -> a -> Bool
== String
expectedType) forall a b. (a -> b) -> a -> b
$
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> String -> DeserializationError
DeserializationErrorFileType String
actualType String
expectedType

{-------------------------------------------------------------------------------
  Access to keys
-------------------------------------------------------------------------------}

-- | MonadReader-like monad, specialized to key environments
class (ReportSchemaErrors m, MonadError DeserializationError m) => MonadKeys m where
  localKeys :: (KeyEnv -> KeyEnv) -> m a -> m a
  askKeys   :: m KeyEnv

readKeyAsId :: MonadKeys m => JSValue -> m (Some PublicKey)
readKeyAsId :: forall (m :: * -> *). MonadKeys m => JSValue -> m (Some PublicKey)
readKeyAsId (JSString String
kId) = forall (m :: * -> *). MonadKeys m => KeyId -> m (Some PublicKey)
lookupKey (String -> KeyId
KeyId String
kId)
readKeyAsId JSValue
val            = forall (m :: * -> *) a.
ReportSchemaErrors m =>
String -> JSValue -> m a
expected' String
"key ID" JSValue
val

addKeys :: MonadKeys m => KeyEnv -> m a -> m a
addKeys :: forall (m :: * -> *) a. MonadKeys m => KeyEnv -> m a -> m a
addKeys KeyEnv
keys = forall (m :: * -> *) a.
MonadKeys m =>
(KeyEnv -> KeyEnv) -> m a -> m a
localKeys (KeyEnv -> KeyEnv -> KeyEnv
KeyEnv.union KeyEnv
keys)

withKeys :: MonadKeys m => KeyEnv -> m a -> m a
withKeys :: forall (m :: * -> *) a. MonadKeys m => KeyEnv -> m a -> m a
withKeys KeyEnv
keys = forall (m :: * -> *) a.
MonadKeys m =>
(KeyEnv -> KeyEnv) -> m a -> m a
localKeys (forall a b. a -> b -> a
const KeyEnv
keys)

lookupKey :: MonadKeys m => KeyId -> m (Some PublicKey)
lookupKey :: forall (m :: * -> *). MonadKeys m => KeyId -> m (Some PublicKey)
lookupKey KeyId
kId = do
    KeyEnv
keyEnv <- forall (m :: * -> *). MonadKeys m => m KeyEnv
askKeys
    case KeyId -> KeyEnv -> Maybe (Some PublicKey)
KeyEnv.lookup KeyId
kId KeyEnv
keyEnv of
      Just Some PublicKey
key -> forall (m :: * -> *) a. Monad m => a -> m a
return Some PublicKey
key
      Maybe (Some PublicKey)
Nothing  -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ KeyId -> DeserializationError
DeserializationErrorUnknownKey KeyId
kId

{-------------------------------------------------------------------------------
  Reading
-------------------------------------------------------------------------------}

newtype ReadJSON_Keys_Layout a = ReadJSON_Keys_Layout {
    forall a.
ReadJSON_Keys_Layout a
-> ExceptT DeserializationError (Reader (RepoLayout, KeyEnv)) a
unReadJSON_Keys_Layout :: ExceptT DeserializationError (Reader (RepoLayout, KeyEnv)) a
  }
  deriving ( forall a b. a -> ReadJSON_Keys_Layout b -> ReadJSON_Keys_Layout a
forall a b.
(a -> b) -> ReadJSON_Keys_Layout a -> ReadJSON_Keys_Layout b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ReadJSON_Keys_Layout b -> ReadJSON_Keys_Layout a
$c<$ :: forall a b. a -> ReadJSON_Keys_Layout b -> ReadJSON_Keys_Layout a
fmap :: forall a b.
(a -> b) -> ReadJSON_Keys_Layout a -> ReadJSON_Keys_Layout b
$cfmap :: forall a b.
(a -> b) -> ReadJSON_Keys_Layout a -> ReadJSON_Keys_Layout b
Functor
           , Functor ReadJSON_Keys_Layout
forall a. a -> ReadJSON_Keys_Layout a
forall a b.
ReadJSON_Keys_Layout a
-> ReadJSON_Keys_Layout b -> ReadJSON_Keys_Layout a
forall a b.
ReadJSON_Keys_Layout a
-> ReadJSON_Keys_Layout b -> ReadJSON_Keys_Layout b
forall a b.
ReadJSON_Keys_Layout (a -> b)
-> ReadJSON_Keys_Layout a -> ReadJSON_Keys_Layout b
forall a b c.
(a -> b -> c)
-> ReadJSON_Keys_Layout a
-> ReadJSON_Keys_Layout b
-> ReadJSON_Keys_Layout c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b.
ReadJSON_Keys_Layout a
-> ReadJSON_Keys_Layout b -> ReadJSON_Keys_Layout a
$c<* :: forall a b.
ReadJSON_Keys_Layout a
-> ReadJSON_Keys_Layout b -> ReadJSON_Keys_Layout a
*> :: forall a b.
ReadJSON_Keys_Layout a
-> ReadJSON_Keys_Layout b -> ReadJSON_Keys_Layout b
$c*> :: forall a b.
ReadJSON_Keys_Layout a
-> ReadJSON_Keys_Layout b -> ReadJSON_Keys_Layout b
liftA2 :: forall a b c.
(a -> b -> c)
-> ReadJSON_Keys_Layout a
-> ReadJSON_Keys_Layout b
-> ReadJSON_Keys_Layout c
$cliftA2 :: forall a b c.
(a -> b -> c)
-> ReadJSON_Keys_Layout a
-> ReadJSON_Keys_Layout b
-> ReadJSON_Keys_Layout c
<*> :: forall a b.
ReadJSON_Keys_Layout (a -> b)
-> ReadJSON_Keys_Layout a -> ReadJSON_Keys_Layout b
$c<*> :: forall a b.
ReadJSON_Keys_Layout (a -> b)
-> ReadJSON_Keys_Layout a -> ReadJSON_Keys_Layout b
pure :: forall a. a -> ReadJSON_Keys_Layout a
$cpure :: forall a. a -> ReadJSON_Keys_Layout a
Applicative
           , Applicative ReadJSON_Keys_Layout
forall a. a -> ReadJSON_Keys_Layout a
forall a b.
ReadJSON_Keys_Layout a
-> ReadJSON_Keys_Layout b -> ReadJSON_Keys_Layout b
forall a b.
ReadJSON_Keys_Layout a
-> (a -> ReadJSON_Keys_Layout b) -> ReadJSON_Keys_Layout b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> ReadJSON_Keys_Layout a
$creturn :: forall a. a -> ReadJSON_Keys_Layout a
>> :: forall a b.
ReadJSON_Keys_Layout a
-> ReadJSON_Keys_Layout b -> ReadJSON_Keys_Layout b
$c>> :: forall a b.
ReadJSON_Keys_Layout a
-> ReadJSON_Keys_Layout b -> ReadJSON_Keys_Layout b
>>= :: forall a b.
ReadJSON_Keys_Layout a
-> (a -> ReadJSON_Keys_Layout b) -> ReadJSON_Keys_Layout b
$c>>= :: forall a b.
ReadJSON_Keys_Layout a
-> (a -> ReadJSON_Keys_Layout b) -> ReadJSON_Keys_Layout b
Monad
           , MonadError DeserializationError
           )

newtype ReadJSON_Keys_NoLayout a = ReadJSON_Keys_NoLayout {
    forall a.
ReadJSON_Keys_NoLayout a
-> ExceptT DeserializationError (Reader KeyEnv) a
unReadJSON_Keys_NoLayout :: ExceptT DeserializationError (Reader KeyEnv) a
  }
  deriving ( forall a b.
a -> ReadJSON_Keys_NoLayout b -> ReadJSON_Keys_NoLayout a
forall a b.
(a -> b) -> ReadJSON_Keys_NoLayout a -> ReadJSON_Keys_NoLayout b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b.
a -> ReadJSON_Keys_NoLayout b -> ReadJSON_Keys_NoLayout a
$c<$ :: forall a b.
a -> ReadJSON_Keys_NoLayout b -> ReadJSON_Keys_NoLayout a
fmap :: forall a b.
(a -> b) -> ReadJSON_Keys_NoLayout a -> ReadJSON_Keys_NoLayout b
$cfmap :: forall a b.
(a -> b) -> ReadJSON_Keys_NoLayout a -> ReadJSON_Keys_NoLayout b
Functor
           , Functor ReadJSON_Keys_NoLayout
forall a. a -> ReadJSON_Keys_NoLayout a
forall a b.
ReadJSON_Keys_NoLayout a
-> ReadJSON_Keys_NoLayout b -> ReadJSON_Keys_NoLayout a
forall a b.
ReadJSON_Keys_NoLayout a
-> ReadJSON_Keys_NoLayout b -> ReadJSON_Keys_NoLayout b
forall a b.
ReadJSON_Keys_NoLayout (a -> b)
-> ReadJSON_Keys_NoLayout a -> ReadJSON_Keys_NoLayout b
forall a b c.
(a -> b -> c)
-> ReadJSON_Keys_NoLayout a
-> ReadJSON_Keys_NoLayout b
-> ReadJSON_Keys_NoLayout c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b.
ReadJSON_Keys_NoLayout a
-> ReadJSON_Keys_NoLayout b -> ReadJSON_Keys_NoLayout a
$c<* :: forall a b.
ReadJSON_Keys_NoLayout a
-> ReadJSON_Keys_NoLayout b -> ReadJSON_Keys_NoLayout a
*> :: forall a b.
ReadJSON_Keys_NoLayout a
-> ReadJSON_Keys_NoLayout b -> ReadJSON_Keys_NoLayout b
$c*> :: forall a b.
ReadJSON_Keys_NoLayout a
-> ReadJSON_Keys_NoLayout b -> ReadJSON_Keys_NoLayout b
liftA2 :: forall a b c.
(a -> b -> c)
-> ReadJSON_Keys_NoLayout a
-> ReadJSON_Keys_NoLayout b
-> ReadJSON_Keys_NoLayout c
$cliftA2 :: forall a b c.
(a -> b -> c)
-> ReadJSON_Keys_NoLayout a
-> ReadJSON_Keys_NoLayout b
-> ReadJSON_Keys_NoLayout c
<*> :: forall a b.
ReadJSON_Keys_NoLayout (a -> b)
-> ReadJSON_Keys_NoLayout a -> ReadJSON_Keys_NoLayout b
$c<*> :: forall a b.
ReadJSON_Keys_NoLayout (a -> b)
-> ReadJSON_Keys_NoLayout a -> ReadJSON_Keys_NoLayout b
pure :: forall a. a -> ReadJSON_Keys_NoLayout a
$cpure :: forall a. a -> ReadJSON_Keys_NoLayout a
Applicative
           , Applicative ReadJSON_Keys_NoLayout
forall a. a -> ReadJSON_Keys_NoLayout a
forall a b.
ReadJSON_Keys_NoLayout a
-> ReadJSON_Keys_NoLayout b -> ReadJSON_Keys_NoLayout b
forall a b.
ReadJSON_Keys_NoLayout a
-> (a -> ReadJSON_Keys_NoLayout b) -> ReadJSON_Keys_NoLayout b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> ReadJSON_Keys_NoLayout a
$creturn :: forall a. a -> ReadJSON_Keys_NoLayout a
>> :: forall a b.
ReadJSON_Keys_NoLayout a
-> ReadJSON_Keys_NoLayout b -> ReadJSON_Keys_NoLayout b
$c>> :: forall a b.
ReadJSON_Keys_NoLayout a
-> ReadJSON_Keys_NoLayout b -> ReadJSON_Keys_NoLayout b
>>= :: forall a b.
ReadJSON_Keys_NoLayout a
-> (a -> ReadJSON_Keys_NoLayout b) -> ReadJSON_Keys_NoLayout b
$c>>= :: forall a b.
ReadJSON_Keys_NoLayout a
-> (a -> ReadJSON_Keys_NoLayout b) -> ReadJSON_Keys_NoLayout b
Monad
           , MonadError DeserializationError
           )

newtype ReadJSON_NoKeys_NoLayout a = ReadJSON_NoKeys_NoLayout {
    forall a.
ReadJSON_NoKeys_NoLayout a -> Except DeserializationError a
unReadJSON_NoKeys_NoLayout :: Except DeserializationError a
  }
  deriving ( forall a b.
a -> ReadJSON_NoKeys_NoLayout b -> ReadJSON_NoKeys_NoLayout a
forall a b.
(a -> b)
-> ReadJSON_NoKeys_NoLayout a -> ReadJSON_NoKeys_NoLayout b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b.
a -> ReadJSON_NoKeys_NoLayout b -> ReadJSON_NoKeys_NoLayout a
$c<$ :: forall a b.
a -> ReadJSON_NoKeys_NoLayout b -> ReadJSON_NoKeys_NoLayout a
fmap :: forall a b.
(a -> b)
-> ReadJSON_NoKeys_NoLayout a -> ReadJSON_NoKeys_NoLayout b
$cfmap :: forall a b.
(a -> b)
-> ReadJSON_NoKeys_NoLayout a -> ReadJSON_NoKeys_NoLayout b
Functor
           , Functor ReadJSON_NoKeys_NoLayout
forall a. a -> ReadJSON_NoKeys_NoLayout a
forall a b.
ReadJSON_NoKeys_NoLayout a
-> ReadJSON_NoKeys_NoLayout b -> ReadJSON_NoKeys_NoLayout a
forall a b.
ReadJSON_NoKeys_NoLayout a
-> ReadJSON_NoKeys_NoLayout b -> ReadJSON_NoKeys_NoLayout b
forall a b.
ReadJSON_NoKeys_NoLayout (a -> b)
-> ReadJSON_NoKeys_NoLayout a -> ReadJSON_NoKeys_NoLayout b
forall a b c.
(a -> b -> c)
-> ReadJSON_NoKeys_NoLayout a
-> ReadJSON_NoKeys_NoLayout b
-> ReadJSON_NoKeys_NoLayout c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b.
ReadJSON_NoKeys_NoLayout a
-> ReadJSON_NoKeys_NoLayout b -> ReadJSON_NoKeys_NoLayout a
$c<* :: forall a b.
ReadJSON_NoKeys_NoLayout a
-> ReadJSON_NoKeys_NoLayout b -> ReadJSON_NoKeys_NoLayout a
*> :: forall a b.
ReadJSON_NoKeys_NoLayout a
-> ReadJSON_NoKeys_NoLayout b -> ReadJSON_NoKeys_NoLayout b
$c*> :: forall a b.
ReadJSON_NoKeys_NoLayout a
-> ReadJSON_NoKeys_NoLayout b -> ReadJSON_NoKeys_NoLayout b
liftA2 :: forall a b c.
(a -> b -> c)
-> ReadJSON_NoKeys_NoLayout a
-> ReadJSON_NoKeys_NoLayout b
-> ReadJSON_NoKeys_NoLayout c
$cliftA2 :: forall a b c.
(a -> b -> c)
-> ReadJSON_NoKeys_NoLayout a
-> ReadJSON_NoKeys_NoLayout b
-> ReadJSON_NoKeys_NoLayout c
<*> :: forall a b.
ReadJSON_NoKeys_NoLayout (a -> b)
-> ReadJSON_NoKeys_NoLayout a -> ReadJSON_NoKeys_NoLayout b
$c<*> :: forall a b.
ReadJSON_NoKeys_NoLayout (a -> b)
-> ReadJSON_NoKeys_NoLayout a -> ReadJSON_NoKeys_NoLayout b
pure :: forall a. a -> ReadJSON_NoKeys_NoLayout a
$cpure :: forall a. a -> ReadJSON_NoKeys_NoLayout a
Applicative
           , Applicative ReadJSON_NoKeys_NoLayout
forall a. a -> ReadJSON_NoKeys_NoLayout a
forall a b.
ReadJSON_NoKeys_NoLayout a
-> ReadJSON_NoKeys_NoLayout b -> ReadJSON_NoKeys_NoLayout b
forall a b.
ReadJSON_NoKeys_NoLayout a
-> (a -> ReadJSON_NoKeys_NoLayout b) -> ReadJSON_NoKeys_NoLayout b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> ReadJSON_NoKeys_NoLayout a
$creturn :: forall a. a -> ReadJSON_NoKeys_NoLayout a
>> :: forall a b.
ReadJSON_NoKeys_NoLayout a
-> ReadJSON_NoKeys_NoLayout b -> ReadJSON_NoKeys_NoLayout b
$c>> :: forall a b.
ReadJSON_NoKeys_NoLayout a
-> ReadJSON_NoKeys_NoLayout b -> ReadJSON_NoKeys_NoLayout b
>>= :: forall a b.
ReadJSON_NoKeys_NoLayout a
-> (a -> ReadJSON_NoKeys_NoLayout b) -> ReadJSON_NoKeys_NoLayout b
$c>>= :: forall a b.
ReadJSON_NoKeys_NoLayout a
-> (a -> ReadJSON_NoKeys_NoLayout b) -> ReadJSON_NoKeys_NoLayout b
Monad
           , MonadError DeserializationError
           )

instance ReportSchemaErrors ReadJSON_Keys_Layout where
  expected :: forall a. String -> Maybe String -> ReadJSON_Keys_Layout a
expected String
str Maybe String
mgot = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> DeserializationError
expectedError String
str Maybe String
mgot
instance ReportSchemaErrors ReadJSON_Keys_NoLayout where
  expected :: forall a. String -> Maybe String -> ReadJSON_Keys_NoLayout a
expected String
str Maybe String
mgot = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> DeserializationError
expectedError String
str Maybe String
mgot
instance ReportSchemaErrors ReadJSON_NoKeys_NoLayout where
  expected :: forall a. String -> Maybe String -> ReadJSON_NoKeys_NoLayout a
expected String
str Maybe String
mgot = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> DeserializationError
expectedError String
str Maybe String
mgot

expectedError :: Expected -> Maybe Got -> DeserializationError
expectedError :: String -> Maybe String -> DeserializationError
expectedError String
str Maybe String
mgot = String -> DeserializationError
DeserializationErrorSchema String
msg
  where
    msg :: String
msg = case Maybe String
mgot of
            Maybe String
Nothing  -> String
"Expected " forall a. [a] -> [a] -> [a]
++ String
str
            Just String
got -> String
"Expected " forall a. [a] -> [a] -> [a]
++ String
str forall a. [a] -> [a] -> [a]
++ String
" but got " forall a. [a] -> [a] -> [a]
++ String
got

instance MonadReader RepoLayout ReadJSON_Keys_Layout where
  ask :: ReadJSON_Keys_Layout RepoLayout
ask         = forall a.
ExceptT DeserializationError (Reader (RepoLayout, KeyEnv)) a
-> ReadJSON_Keys_Layout a
ReadJSON_Keys_Layout forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall r (m :: * -> *). MonadReader r m => m r
ask
  local :: forall a.
(RepoLayout -> RepoLayout)
-> ReadJSON_Keys_Layout a -> ReadJSON_Keys_Layout a
local RepoLayout -> RepoLayout
f ReadJSON_Keys_Layout a
act = forall a.
ExceptT DeserializationError (Reader (RepoLayout, KeyEnv)) a
-> ReadJSON_Keys_Layout a
ReadJSON_Keys_Layout forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first RepoLayout -> RepoLayout
f) ExceptT DeserializationError (Reader (RepoLayout, KeyEnv)) a
act'
    where
      act' :: ExceptT DeserializationError (Reader (RepoLayout, KeyEnv)) a
act' = forall a.
ReadJSON_Keys_Layout a
-> ExceptT DeserializationError (Reader (RepoLayout, KeyEnv)) a
unReadJSON_Keys_Layout ReadJSON_Keys_Layout a
act

instance MonadKeys ReadJSON_Keys_Layout where
  askKeys :: ReadJSON_Keys_Layout KeyEnv
askKeys         = forall a.
ExceptT DeserializationError (Reader (RepoLayout, KeyEnv)) a
-> ReadJSON_Keys_Layout a
ReadJSON_Keys_Layout forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall r (m :: * -> *). MonadReader r m => m r
ask
  localKeys :: forall a.
(KeyEnv -> KeyEnv)
-> ReadJSON_Keys_Layout a -> ReadJSON_Keys_Layout a
localKeys KeyEnv -> KeyEnv
f ReadJSON_Keys_Layout a
act = forall a.
ExceptT DeserializationError (Reader (RepoLayout, KeyEnv)) a
-> ReadJSON_Keys_Layout a
ReadJSON_Keys_Layout forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second KeyEnv -> KeyEnv
f) ExceptT DeserializationError (Reader (RepoLayout, KeyEnv)) a
act'
    where
      act' :: ExceptT DeserializationError (Reader (RepoLayout, KeyEnv)) a
act' = forall a.
ReadJSON_Keys_Layout a
-> ExceptT DeserializationError (Reader (RepoLayout, KeyEnv)) a
unReadJSON_Keys_Layout ReadJSON_Keys_Layout a
act

instance MonadKeys ReadJSON_Keys_NoLayout where
  askKeys :: ReadJSON_Keys_NoLayout KeyEnv
askKeys         = forall a.
ExceptT DeserializationError (Reader KeyEnv) a
-> ReadJSON_Keys_NoLayout a
ReadJSON_Keys_NoLayout forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *). MonadReader r m => m r
ask
  localKeys :: forall a.
(KeyEnv -> KeyEnv)
-> ReadJSON_Keys_NoLayout a -> ReadJSON_Keys_NoLayout a
localKeys KeyEnv -> KeyEnv
f ReadJSON_Keys_NoLayout a
act = forall a.
ExceptT DeserializationError (Reader KeyEnv) a
-> ReadJSON_Keys_NoLayout a
ReadJSON_Keys_NoLayout forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local KeyEnv -> KeyEnv
f ExceptT DeserializationError (Reader KeyEnv) a
act'
    where
      act' :: ExceptT DeserializationError (Reader KeyEnv) a
act' = forall a.
ReadJSON_Keys_NoLayout a
-> ExceptT DeserializationError (Reader KeyEnv) a
unReadJSON_Keys_NoLayout ReadJSON_Keys_NoLayout a
act

runReadJSON_Keys_Layout :: KeyEnv
                        -> RepoLayout
                        -> ReadJSON_Keys_Layout a
                        -> Either DeserializationError a
runReadJSON_Keys_Layout :: forall a.
KeyEnv
-> RepoLayout
-> ReadJSON_Keys_Layout a
-> Either DeserializationError a
runReadJSON_Keys_Layout KeyEnv
keyEnv RepoLayout
repoLayout ReadJSON_Keys_Layout a
act =
    forall r a. Reader r a -> r -> a
runReader (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (forall a.
ReadJSON_Keys_Layout a
-> ExceptT DeserializationError (Reader (RepoLayout, KeyEnv)) a
unReadJSON_Keys_Layout ReadJSON_Keys_Layout a
act)) (RepoLayout
repoLayout, KeyEnv
keyEnv)

runReadJSON_Keys_NoLayout :: KeyEnv
                          -> ReadJSON_Keys_NoLayout a
                          -> Either DeserializationError a
runReadJSON_Keys_NoLayout :: forall a.
KeyEnv -> ReadJSON_Keys_NoLayout a -> Either DeserializationError a
runReadJSON_Keys_NoLayout KeyEnv
keyEnv ReadJSON_Keys_NoLayout a
act =
    forall r a. Reader r a -> r -> a
runReader (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (forall a.
ReadJSON_Keys_NoLayout a
-> ExceptT DeserializationError (Reader KeyEnv) a
unReadJSON_Keys_NoLayout ReadJSON_Keys_NoLayout a
act)) KeyEnv
keyEnv

runReadJSON_NoKeys_NoLayout :: ReadJSON_NoKeys_NoLayout a
                            -> Either DeserializationError a
runReadJSON_NoKeys_NoLayout :: forall a.
ReadJSON_NoKeys_NoLayout a -> Either DeserializationError a
runReadJSON_NoKeys_NoLayout ReadJSON_NoKeys_NoLayout a
act =
    forall e a. Except e a -> Either e a
runExcept (forall a.
ReadJSON_NoKeys_NoLayout a -> Except DeserializationError a
unReadJSON_NoKeys_NoLayout ReadJSON_NoKeys_NoLayout a
act)

{-------------------------------------------------------------------------------
  Utility
-------------------------------------------------------------------------------}

parseJSON_Keys_Layout :: FromJSON ReadJSON_Keys_Layout a
                      => KeyEnv
                      -> RepoLayout
                      -> BS.L.ByteString
                      -> Either DeserializationError a
parseJSON_Keys_Layout :: forall a.
FromJSON ReadJSON_Keys_Layout a =>
KeyEnv -> RepoLayout -> ByteString -> Either DeserializationError a
parseJSON_Keys_Layout KeyEnv
keyEnv RepoLayout
repoLayout ByteString
bs =
    case ByteString -> Either String JSValue
parseCanonicalJSON ByteString
bs of
      Left  String
err -> forall a b. a -> Either a b
Left (String -> DeserializationError
DeserializationErrorMalformed String
err)
      Right JSValue
val -> forall a.
KeyEnv
-> RepoLayout
-> ReadJSON_Keys_Layout a
-> Either DeserializationError a
runReadJSON_Keys_Layout KeyEnv
keyEnv RepoLayout
repoLayout (forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON JSValue
val)

parseJSON_Keys_NoLayout :: FromJSON ReadJSON_Keys_NoLayout a
                        => KeyEnv
                        -> BS.L.ByteString
                        -> Either DeserializationError a
parseJSON_Keys_NoLayout :: forall a.
FromJSON ReadJSON_Keys_NoLayout a =>
KeyEnv -> ByteString -> Either DeserializationError a
parseJSON_Keys_NoLayout KeyEnv
keyEnv ByteString
bs =
    case ByteString -> Either String JSValue
parseCanonicalJSON ByteString
bs of
      Left  String
err -> forall a b. a -> Either a b
Left (String -> DeserializationError
DeserializationErrorMalformed String
err)
      Right JSValue
val -> forall a.
KeyEnv -> ReadJSON_Keys_NoLayout a -> Either DeserializationError a
runReadJSON_Keys_NoLayout KeyEnv
keyEnv (forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON JSValue
val)

parseJSON_NoKeys_NoLayout :: FromJSON ReadJSON_NoKeys_NoLayout a
                          => BS.L.ByteString
                          -> Either DeserializationError a
parseJSON_NoKeys_NoLayout :: forall a.
FromJSON ReadJSON_NoKeys_NoLayout a =>
ByteString -> Either DeserializationError a
parseJSON_NoKeys_NoLayout ByteString
bs =
    case ByteString -> Either String JSValue
parseCanonicalJSON ByteString
bs of
      Left  String
err -> forall a b. a -> Either a b
Left (String -> DeserializationError
DeserializationErrorMalformed String
err)
      Right JSValue
val -> forall a.
ReadJSON_NoKeys_NoLayout a -> Either DeserializationError a
runReadJSON_NoKeys_NoLayout (forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON JSValue
val)

readJSON_Keys_Layout :: ( FsRoot root
                        , FromJSON ReadJSON_Keys_Layout a
                        )
                     => KeyEnv
                     -> RepoLayout
                     -> Path root
                     -> IO (Either DeserializationError a)
readJSON_Keys_Layout :: forall root a.
(FsRoot root, FromJSON ReadJSON_Keys_Layout a) =>
KeyEnv
-> RepoLayout -> Path root -> IO (Either DeserializationError a)
readJSON_Keys_Layout KeyEnv
keyEnv RepoLayout
repoLayout Path root
fp = do
    forall root r.
FsRoot root =>
Path root -> IOMode -> (Handle -> IO r) -> IO r
withFile Path root
fp IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
      ByteString
bs <- Handle -> IO ByteString
BS.L.hGetContents Handle
h
      forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall a.
FromJSON ReadJSON_Keys_Layout a =>
KeyEnv -> RepoLayout -> ByteString -> Either DeserializationError a
parseJSON_Keys_Layout KeyEnv
keyEnv RepoLayout
repoLayout ByteString
bs

readJSON_Keys_NoLayout :: ( FsRoot root
                          , FromJSON ReadJSON_Keys_NoLayout a
                          )
                       => KeyEnv
                       -> Path root
                       -> IO (Either DeserializationError a)
readJSON_Keys_NoLayout :: forall root a.
(FsRoot root, FromJSON ReadJSON_Keys_NoLayout a) =>
KeyEnv -> Path root -> IO (Either DeserializationError a)
readJSON_Keys_NoLayout KeyEnv
keyEnv Path root
fp = do
    forall root r.
FsRoot root =>
Path root -> IOMode -> (Handle -> IO r) -> IO r
withFile Path root
fp IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
      ByteString
bs <- Handle -> IO ByteString
BS.L.hGetContents Handle
h
      forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall a.
FromJSON ReadJSON_Keys_NoLayout a =>
KeyEnv -> ByteString -> Either DeserializationError a
parseJSON_Keys_NoLayout KeyEnv
keyEnv ByteString
bs

readJSON_NoKeys_NoLayout :: ( FsRoot root
                            , FromJSON ReadJSON_NoKeys_NoLayout a
                            )
                         => Path root
                         -> IO (Either DeserializationError a)
readJSON_NoKeys_NoLayout :: forall root a.
(FsRoot root, FromJSON ReadJSON_NoKeys_NoLayout a) =>
Path root -> IO (Either DeserializationError a)
readJSON_NoKeys_NoLayout Path root
fp = do
    forall root r.
FsRoot root =>
Path root -> IOMode -> (Handle -> IO r) -> IO r
withFile Path root
fp IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
      ByteString
bs <- Handle -> IO ByteString
BS.L.hGetContents Handle
h
      forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall a.
FromJSON ReadJSON_NoKeys_NoLayout a =>
ByteString -> Either DeserializationError a
parseJSON_NoKeys_NoLayout ByteString
bs

{-------------------------------------------------------------------------------
  Writing
-------------------------------------------------------------------------------}

newtype WriteJSON a = WriteJSON {
    forall a. WriteJSON a -> Reader RepoLayout a
unWriteJSON :: Reader RepoLayout a
  }
  deriving ( forall a b. a -> WriteJSON b -> WriteJSON a
forall a b. (a -> b) -> WriteJSON a -> WriteJSON b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> WriteJSON b -> WriteJSON a
$c<$ :: forall a b. a -> WriteJSON b -> WriteJSON a
fmap :: forall a b. (a -> b) -> WriteJSON a -> WriteJSON b
$cfmap :: forall a b. (a -> b) -> WriteJSON a -> WriteJSON b
Functor
           , Functor WriteJSON
forall a. a -> WriteJSON a
forall a b. WriteJSON a -> WriteJSON b -> WriteJSON a
forall a b. WriteJSON a -> WriteJSON b -> WriteJSON b
forall a b. WriteJSON (a -> b) -> WriteJSON a -> WriteJSON b
forall a b c.
(a -> b -> c) -> WriteJSON a -> WriteJSON b -> WriteJSON c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. WriteJSON a -> WriteJSON b -> WriteJSON a
$c<* :: forall a b. WriteJSON a -> WriteJSON b -> WriteJSON a
*> :: forall a b. WriteJSON a -> WriteJSON b -> WriteJSON b
$c*> :: forall a b. WriteJSON a -> WriteJSON b -> WriteJSON b
liftA2 :: forall a b c.
(a -> b -> c) -> WriteJSON a -> WriteJSON b -> WriteJSON c
$cliftA2 :: forall a b c.
(a -> b -> c) -> WriteJSON a -> WriteJSON b -> WriteJSON c
<*> :: forall a b. WriteJSON (a -> b) -> WriteJSON a -> WriteJSON b
$c<*> :: forall a b. WriteJSON (a -> b) -> WriteJSON a -> WriteJSON b
pure :: forall a. a -> WriteJSON a
$cpure :: forall a. a -> WriteJSON a
Applicative
           , Applicative WriteJSON
forall a. a -> WriteJSON a
forall a b. WriteJSON a -> WriteJSON b -> WriteJSON b
forall a b. WriteJSON a -> (a -> WriteJSON b) -> WriteJSON b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> WriteJSON a
$creturn :: forall a. a -> WriteJSON a
>> :: forall a b. WriteJSON a -> WriteJSON b -> WriteJSON b
$c>> :: forall a b. WriteJSON a -> WriteJSON b -> WriteJSON b
>>= :: forall a b. WriteJSON a -> (a -> WriteJSON b) -> WriteJSON b
$c>>= :: forall a b. WriteJSON a -> (a -> WriteJSON b) -> WriteJSON b
Monad
           , MonadReader RepoLayout
           )

runWriteJSON :: RepoLayout -> WriteJSON a -> a
runWriteJSON :: forall a. RepoLayout -> WriteJSON a -> a
runWriteJSON RepoLayout
repoLayout WriteJSON a
act = forall r a. Reader r a -> r -> a
runReader (forall a. WriteJSON a -> Reader RepoLayout a
unWriteJSON WriteJSON a
act) RepoLayout
repoLayout

{-------------------------------------------------------------------------------
  Writing: Utility
-------------------------------------------------------------------------------}

-- | Render to canonical JSON format
renderJSON :: ToJSON WriteJSON a => RepoLayout -> a -> BS.L.ByteString
renderJSON :: forall a. ToJSON WriteJSON a => RepoLayout -> a -> ByteString
renderJSON RepoLayout
repoLayout = JSValue -> ByteString
renderCanonicalJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RepoLayout -> WriteJSON a -> a
runWriteJSON RepoLayout
repoLayout forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON

-- | Variation on 'renderJSON' for files that don't require the repo layout
renderJSON_NoLayout :: ToJSON Identity a => a -> BS.L.ByteString
renderJSON_NoLayout :: forall a. ToJSON Identity a => a -> ByteString
renderJSON_NoLayout = JSValue -> ByteString
renderCanonicalJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON

writeJSON :: ToJSON WriteJSON a => RepoLayout -> Path Absolute -> a -> IO ()
writeJSON :: forall a.
ToJSON WriteJSON a =>
RepoLayout -> Path Absolute -> a -> IO ()
writeJSON RepoLayout
repoLayout Path Absolute
fp = forall root. FsRoot root => Path root -> ByteString -> IO ()
writeLazyByteString Path Absolute
fp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON WriteJSON a => RepoLayout -> a -> ByteString
renderJSON RepoLayout
repoLayout

writeJSON_NoLayout :: ToJSON Identity a => Path Absolute -> a -> IO ()
writeJSON_NoLayout :: forall a. ToJSON Identity a => Path Absolute -> a -> IO ()
writeJSON_NoLayout Path Absolute
fp = forall root. FsRoot root => Path root -> ByteString -> IO ()
writeLazyByteString Path Absolute
fp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON Identity a => a -> ByteString
renderJSON_NoLayout

writeKeyAsId :: Some PublicKey -> JSValue
writeKeyAsId :: Some PublicKey -> JSValue
writeKeyAsId = String -> JSValue
JSString forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyId -> String
keyIdString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (key :: * -> *). HasKeyId key => Some key -> KeyId
someKeyId