    -- |
    module Hackage.Security.Util.JSON (
        -- * Type classes
        ToJSON(..)
      , FromJSON(..)
      , ToObjectKey(..)
      , FromObjectKey(..)
      , ReportSchemaErrors(..)
      , Expected
      , Got
      , expected'
        -- * Utility
      , fromJSObject
      , fromJSField
      , fromJSOptField
      , mkObject
        -- * Re-exports
      , JSValue(..)
      , Int54
      ) where

    import Prelude
    import Control.Monad (liftM)
    import Data.Maybe (catMaybes)
    import Data.Map (Map)
    import Data.Time
    import Text.JSON.Canonical
    import Network.URI
    import qualified Data.Map as Map

    import Hackage.Security.Util.Path

    {-------------------------------------------------------------------------------
      ToJSON and FromJSON classes

      We parameterize over the monad here to avoid mutual module dependencies.
    -------------------------------------------------------------------------------}

    class ToJSON m a where
      toJSON :: a -> m JSValue

    class FromJSON m a where
      fromJSON :: JSValue -> m a

    -- | Used in the 'ToJSON' instance for 'Map'
    class ToObjectKey m a where
      toObjectKey :: a -> m String

    -- | Used in the 'FromJSON' instance for 'Map'
    class FromObjectKey m a where
      fromObjectKey :: String -> m (Maybe a)

    -- | Monads in which we can report schema errors
    class (Applicative m, Monad m) => ReportSchemaErrors m where
      expected :: Expected -> Maybe Got -> m a

    type Expected = String
    type Got      = String

    expected' :: ReportSchemaErrors m => Expected -> JSValue -> m a
    expected' :: forall (m :: * -> *) a.
    ReportSchemaErrors m =>
    Expected -> JSValue -> m a
    expected' Expected
    descr JSValue
    val = Expected -> Maybe Expected -> m a
    forall a. Expected -> Maybe Expected -> m a
    forall (m :: * -> *) a.
    ReportSchemaErrors m =>
    Expected -> Maybe Expected -> m a
    expected Expected
    descr (Expected -> Maybe Expected
    forall a. a -> Maybe a
    Just (JSValue -> Expected
    describeValue JSValue
    val))
      where
        describeValue :: JSValue -> String
        describeValue :: JSValue -> Expected
    describeValue (JSValue
    JSNull    ) = Expected
    "null"
        describeValue (JSBool   Bool
    _) = Expected
    "bool"
        describeValue (JSNum    Int54
    _) = Expected
    "num"
        describeValue (JSString Expected
    _) = Expected
    "string"
        describeValue (JSArray  [JSValue]
    _) = Expected
    "array"
        describeValue (JSObject [(Expected, JSValue)]
    _) = Expected
    "object"

    unknownField :: ReportSchemaErrors m => String -> m a
    unknownField :: forall (m :: * -> *) a. ReportSchemaErrors m => Expected -> m a
    unknownField Expected
    field = Expected -> Maybe Expected -> m a
    forall a. Expected -> Maybe Expected -> m a
    forall (m :: * -> *) a.
    ReportSchemaErrors m =>
    Expected -> Maybe Expected -> m a
    expected (Expected
    "field " Expected -> Expected -> Expected
    forall a. [a] -> [a] -> [a]
    ++ Expected -> Expected
    forall a. Show a => a -> Expected
    show Expected
    field) Maybe Expected
    forall a. Maybe a
    Nothing

    {-------------------------------------------------------------------------------
      ToObjectKey and FromObjectKey instances
    -------------------------------------------------------------------------------}

    instance Monad m => ToObjectKey m String where
      toObjectKey :: Expected -> m Expected
    toObjectKey = Expected -> m Expected
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return

    instance Monad m => FromObjectKey m String where
      fromObjectKey :: Expected -> m (Maybe Expected)
    fromObjectKey = Maybe Expected -> m (Maybe Expected)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe Expected -> m (Maybe Expected))
    -> (Expected -> Maybe Expected) -> Expected -> m (Maybe Expected)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Expected -> Maybe Expected
    forall a. a -> Maybe a
    Just

    instance Monad m => ToObjectKey m (Path root) where
      toObjectKey :: Path root -> m Expected
    toObjectKey (Path Expected
    fp) = Expected -> m Expected
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Expected
    fp

    instance Monad m => FromObjectKey m (Path root) where
      fromObjectKey :: Expected -> m (Maybe (Path root))
    fromObjectKey = (Maybe Expected -> Maybe (Path root))
    -> m (Maybe Expected) -> m (Maybe (Path root))
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM ((Expected -> Path root) -> Maybe Expected -> Maybe (Path root)
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Expected -> Path root
    forall a. Expected -> Path a
    Path) (m (Maybe Expected) -> m (Maybe (Path root)))
    -> (Expected -> m (Maybe Expected))
    -> Expected
    -> m (Maybe (Path root))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Expected -> m (Maybe Expected)
    forall (m :: * -> *) a.
    FromObjectKey m a =>
    Expected -> m (Maybe a)
    fromObjectKey

    {-------------------------------------------------------------------------------
      ToJSON and FromJSON instances
    -------------------------------------------------------------------------------}

    instance Monad m => ToJSON m JSValue where
      toJSON :: JSValue -> m JSValue
    toJSON = JSValue -> m JSValue
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return

    instance Monad m => FromJSON m JSValue where
      fromJSON :: JSValue -> m JSValue
    fromJSON = JSValue -> m JSValue
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return

    instance Monad m => ToJSON m String where
      toJSON :: Expected -> m JSValue
    toJSON = JSValue -> m JSValue
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JSValue -> m JSValue)
    -> (Expected -> JSValue) -> Expected -> m JSValue
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Expected -> JSValue
    JSString

    instance ReportSchemaErrors m => FromJSON m String where
      fromJSON :: JSValue -> m Expected
    fromJSON (JSString Expected
    str) = Expected -> m Expected
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Expected
    str
      fromJSON JSValue
    val            = Expected -> JSValue -> m Expected
    forall (m :: * -> *) a.
    ReportSchemaErrors m =>
    Expected -> JSValue -> m a
    expected' Expected
    "string" JSValue
    val

    instance Monad m => ToJSON m Int54 where
      toJSON :: Int54 -> m JSValue
    toJSON = JSValue -> m JSValue
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JSValue -> m JSValue) -> (Int54 -> JSValue) -> Int54 -> m JSValue
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int54 -> JSValue
    JSNum

    instance ReportSchemaErrors m => FromJSON m Int54 where
      fromJSON :: JSValue -> m Int54
    fromJSON (JSNum Int54
    i) = Int54 -> m Int54
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Int54
    i
      fromJSON JSValue
    val       = Expected -> JSValue -> m Int54
    forall (m :: * -> *) a.
    ReportSchemaErrors m =>
    Expected -> JSValue -> m a
    expected' Expected
    "int" JSValue
    val

    instance
      {-# OVERLAPPABLE #-}
        (Monad m, ToJSON m a) => ToJSON m [a] where
      toJSON :: [a] -> m JSValue
    toJSON = ([JSValue] -> JSValue) -> m [JSValue] -> m JSValue
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM [JSValue] -> JSValue
    JSArray (m [JSValue] -> m JSValue)
    -> ([a] -> m [JSValue]) -> [a] -> m JSValue
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (a -> m JSValue) -> [a] -> m [JSValue]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM a -> m JSValue
    forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
    toJSON

    instance
      {-# OVERLAPPABLE #-}
        (ReportSchemaErrors m, FromJSON m a) => FromJSON m [a] where
      fromJSON :: JSValue -> m [a]
    fromJSON (JSArray [JSValue]
    as) = (JSValue -> m a) -> [JSValue] -> m [a]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM JSValue -> m a
    forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
    fromJSON [JSValue]
    as
      fromJSON JSValue
    val          = Expected -> JSValue -> m [a]
    forall (m :: * -> *) a.
    ReportSchemaErrors m =>
    Expected -> JSValue -> m a
    expected' Expected
    "array" JSValue
    val

    instance Monad m => ToJSON m UTCTime where
      toJSON :: UTCTime -> m JSValue
    toJSON = JSValue -> m JSValue
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JSValue -> m JSValue)
    -> (UTCTime -> JSValue) -> UTCTime -> m JSValue
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Expected -> JSValue
    JSString (Expected -> JSValue)
    -> (UTCTime -> Expected) -> UTCTime -> JSValue
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . TimeLocale -> Expected -> UTCTime -> Expected
    forall t. FormatTime t => TimeLocale -> Expected -> t -> Expected
    formatTime TimeLocale
    defaultTimeLocale Expected
    "%FT%TZ"

    instance ReportSchemaErrors m => FromJSON m UTCTime where
      fromJSON :: JSValue -> m UTCTime
    fromJSON JSValue
    enc = do
        str <- JSValue -> m Expected
    forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
    fromJSON JSValue
    enc
        case parseTimeM False defaultTimeLocale "%FT%TZ" str of
          Just UTCTime
    time -> UTCTime -> m UTCTime
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return UTCTime
    time
          Maybe UTCTime
    Nothing   -> Expected -> Maybe Expected -> m UTCTime
    forall a. Expected -> Maybe Expected -> m a
    forall (m :: * -> *) a.
    ReportSchemaErrors m =>
    Expected -> Maybe Expected -> m a
    expected Expected
    "valid date-time string" (Expected -> Maybe Expected
    forall a. a -> Maybe a
    Just Expected
    str)

    instance ( Monad m
             , ToObjectKey m k
             , ToJSON m a
             ) => ToJSON m (Map k a) where
      toJSON :: Map k a -> m JSValue
    toJSON = ([(Expected, JSValue)] -> JSValue)
    -> m [(Expected, JSValue)] -> m JSValue
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM [(Expected, JSValue)] -> JSValue
    JSObject (m [(Expected, JSValue)] -> m JSValue)
    -> (Map k a -> m [(Expected, JSValue)]) -> Map k a -> m JSValue
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((k, a) -> m (Expected, JSValue))
    -> [(k, a)] -> m [(Expected, JSValue)]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (k, a) -> m (Expected, JSValue)
    aux ([(k, a)] -> m [(Expected, JSValue)])
    -> (Map k a -> [(k, a)]) -> Map k a -> m [(Expected, JSValue)]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Map k a -> [(k, a)]
    forall k a. Map k a -> [(k, a)]
    Map.toList
        where
          aux :: (k, a) -> m (String, JSValue)
          aux :: (k, a) -> m (Expected, JSValue)
    aux (k
    k, a
    a) = do k' <- k -> m Expected
    forall (m :: * -> *) a. ToObjectKey m a => a -> m Expected
    toObjectKey k
    k; a' <- toJSON a; return (k', a')

    instance ( ReportSchemaErrors m
             , Ord k
             , FromObjectKey m k
             , FromJSON m a
             ) => FromJSON m (Map k a) where
      fromJSON :: JSValue -> m (Map k a)
    fromJSON JSValue
    enc = do
          obj <- JSValue -> m [(Expected, JSValue)]
    forall (m :: * -> *).
    ReportSchemaErrors m =>
    JSValue -> m [(Expected, JSValue)]
    fromJSObject JSValue
    enc
          Map.fromList . catMaybes <$> mapM aux obj
        where
          aux :: (String, JSValue) -> m (Maybe (k, a))
          aux :: (Expected, JSValue) -> m (Maybe (k, a))
    aux (Expected
    k, JSValue
    a) = Maybe k -> a -> Maybe (k, a)
    knownKeys (Maybe k -> a -> Maybe (k, a))
    -> m (Maybe k) -> m (a -> Maybe (k, a))
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Expected -> m (Maybe k)
    forall (m :: * -> *) a.
    FromObjectKey m a =>
    Expected -> m (Maybe a)
    fromObjectKey Expected
    k m (a -> Maybe (k, a)) -> m a -> m (Maybe (k, a))
    forall a b. m (a -> b) -> m a -> m b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> JSValue -> m a
    forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
    fromJSON JSValue
    a
          knownKeys :: Maybe k -> a -> Maybe (k, a)
          knownKeys :: Maybe k -> a -> Maybe (k, a)
    knownKeys Maybe k
    Nothing  a
    _ = Maybe (k, a)
    forall a. Maybe a
    Nothing
          knownKeys (Just k
    k) a
    a = (k, a) -> Maybe (k, a)
    forall a. a -> Maybe a
    Just (k
    k, a
    a)

    instance Monad m => ToJSON m URI where
      toJSON :: URI -> m JSValue
    toJSON = Expected -> m JSValue
    forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
    toJSON (Expected -> m JSValue) -> (URI -> Expected) -> URI -> m JSValue
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . URI -> Expected
    forall a. Show a => a -> Expected
    show

    instance ReportSchemaErrors m => FromJSON m URI where
      fromJSON :: JSValue -> m URI
    fromJSON JSValue
    enc = do
        str <- JSValue -> m Expected
    forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
    fromJSON JSValue
    enc
        case parseURI str of
          Maybe URI
    Nothing  -> Expected -> Maybe Expected -> m URI
    forall a. Expected -> Maybe Expected -> m a
    forall (m :: * -> *) a.
    ReportSchemaErrors m =>
    Expected -> Maybe Expected -> m a
    expected Expected
    "valid URI" (Expected -> Maybe Expected
    forall a. a -> Maybe a
    Just Expected
    str)
          Just URI
    uri -> URI -> m URI
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return URI
    uri

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

    fromJSObject :: ReportSchemaErrors m => JSValue -> m [(String, JSValue)]
    fromJSObject :: forall (m :: * -> *).
    ReportSchemaErrors m =>
    JSValue -> m [(Expected, JSValue)]
    fromJSObject (JSObject [(Expected, JSValue)]
    obj) = [(Expected, JSValue)] -> m [(Expected, JSValue)]
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [(Expected, JSValue)]
    obj
    fromJSObject JSValue
    val            = Expected -> JSValue -> m [(Expected, JSValue)]
    forall (m :: * -> *) a.
    ReportSchemaErrors m =>
    Expected -> JSValue -> m a
    expected' Expected
    "object" JSValue
    val

    -- | Extract a field from a JSON object
    fromJSField :: (ReportSchemaErrors m, FromJSON m a)
                => JSValue -> String -> m a
    fromJSField :: forall (m :: * -> *) a.
    (ReportSchemaErrors m, FromJSON m a) =>
    JSValue -> Expected -> m a
    fromJSField JSValue
    val Expected
    nm = do
        obj <- JSValue -> m [(Expected, JSValue)]
    forall (m :: * -> *).
    ReportSchemaErrors m =>
    JSValue -> m [(Expected, JSValue)]
    fromJSObject JSValue
    val
        case lookup nm obj of
          Just JSValue
    fld -> JSValue -> m a
    forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
    fromJSON JSValue
    fld
          Maybe JSValue
    Nothing  -> Expected -> m a
    forall (m :: * -> *) a. ReportSchemaErrors m => Expected -> m a
    unknownField Expected
    nm

    fromJSOptField :: (ReportSchemaErrors m, FromJSON m a)
                   => JSValue -> String -> m (Maybe a)
    fromJSOptField :: forall (m :: * -> *) a.
    (ReportSchemaErrors m, FromJSON m a) =>
    JSValue -> Expected -> m (Maybe a)
    fromJSOptField JSValue
    val Expected
    nm = do
        obj <- JSValue -> m [(Expected, JSValue)]
    forall (m :: * -> *).
    ReportSchemaErrors m =>
    JSValue -> m [(Expected, JSValue)]
    fromJSObject JSValue
    val
        case lookup nm obj of
          Just JSValue
    fld -> a -> Maybe a
    forall a. a -> Maybe a
    Just (a -> Maybe a) -> m a -> m (Maybe a)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> JSValue -> m a
    forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
    fromJSON JSValue
    fld
          Maybe JSValue
    Nothing  -> Maybe a -> m (Maybe a)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe a
    forall a. Maybe a
    Nothing

    mkObject :: forall m. Monad m => [(String, m JSValue)] -> m JSValue
    mkObject :: forall (m :: * -> *).
    Monad m =>
    [(Expected, m JSValue)] -> m JSValue
    mkObject = ([(Expected, JSValue)] -> JSValue)
    -> m [(Expected, JSValue)] -> m JSValue
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM [(Expected, JSValue)] -> JSValue
    JSObject (m [(Expected, JSValue)] -> m JSValue)
    -> ([(Expected, m JSValue)] -> m [(Expected, JSValue)])
    -> [(Expected, m JSValue)]
    -> m JSValue
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [(Expected, m JSValue)] -> m [(Expected, JSValue)]
    sequenceFields
      where
        sequenceFields :: [(String, m JSValue)] -> m [(String, JSValue)]
        sequenceFields :: [(Expected, m JSValue)] -> m [(Expected, JSValue)]
    sequenceFields []               = [(Expected, JSValue)] -> m [(Expected, JSValue)]
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
        sequenceFields ((Expected
    fld,m JSValue
    val):[(Expected, m JSValue)]
    flds) = do val' <- m JSValue
    val
                                             flds' <- sequenceFields flds
                                             return ((fld,val'):flds')