{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ < 710
{-# LANGUAGE OverlappingInstances #-}
#endif
-- |
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 MyPrelude
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

#if !MIN_VERSION_time(1,5,0)
import System.Locale (defaultTimeLocale)
#endif

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
#if __GLASGOW_HASKELL__ >= 710
  {-# OVERLAPPABLE #-}
#endif
    (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
#if __GLASGOW_HASKELL__ >= 710
  {-# OVERLAPPABLE #-}
#endif
    (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
    Expected
str <- JSValue -> m Expected
forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON JSValue
enc
    case Bool -> TimeLocale -> Expected -> Expected -> Maybe UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> Expected -> Expected -> m t
parseTimeM Bool
False TimeLocale
defaultTimeLocale Expected
"%FT%TZ" Expected
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)
#if !MIN_VERSION_time(1,5,0)
    where
      parseTimeM _trim = parseTime
#endif

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 Expected
k' <- k -> m Expected
forall (m :: * -> *) a. ToObjectKey m a => a -> m Expected
toObjectKey k
k; JSValue
a' <- a -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON a
a; (Expected, JSValue) -> m (Expected, JSValue)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expected
k', JSValue
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
      [(Expected, JSValue)]
obj <- JSValue -> m [(Expected, JSValue)]
forall (m :: * -> *).
ReportSchemaErrors m =>
JSValue -> m [(Expected, JSValue)]
fromJSObject JSValue
enc
      [(k, a)] -> Map k a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(k, a)] -> Map k a)
-> ([Maybe (k, a)] -> [(k, a)]) -> [Maybe (k, a)] -> Map k a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (k, a)] -> [(k, a)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (k, a)] -> Map k a) -> m [Maybe (k, a)] -> m (Map k a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Expected, JSValue) -> m (Maybe (k, a)))
-> [(Expected, JSValue)] -> m [Maybe (k, 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 (Expected, JSValue) -> m (Maybe (k, a))
aux [(Expected, JSValue)]
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
    Expected
str <- JSValue -> m Expected
forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON JSValue
enc
    case Expected -> Maybe URI
parseURI Expected
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
    [(Expected, JSValue)]
obj <- JSValue -> m [(Expected, JSValue)]
forall (m :: * -> *).
ReportSchemaErrors m =>
JSValue -> m [(Expected, JSValue)]
fromJSObject JSValue
val
    case Expected -> [(Expected, JSValue)] -> Maybe JSValue
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Expected
nm [(Expected, JSValue)]
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
    [(Expected, JSValue)]
obj <- JSValue -> m [(Expected, JSValue)]
forall (m :: * -> *).
ReportSchemaErrors m =>
JSValue -> m [(Expected, JSValue)]
fromJSObject JSValue
val
    case Expected -> [(Expected, JSValue)] -> Maybe JSValue
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Expected
nm [(Expected, JSValue)]
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 JSValue
val' <- m JSValue
val
                                         [(Expected, JSValue)]
flds' <- [(Expected, m JSValue)] -> m [(Expected, JSValue)]
sequenceFields [(Expected, m JSValue)]
flds
                                         [(Expected, JSValue)] -> m [(Expected, JSValue)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Expected
fld,JSValue
val')(Expected, JSValue)
-> [(Expected, JSValue)] -> [(Expected, JSValue)]
forall a. a -> [a] -> [a]
:[(Expected, JSValue)]
flds')