{-# LANGUAGE UndecidableInstances #-}

{-|

Copyright:

  This file is part of the package openid-connect.  It is subject to
  the license terms in the LICENSE file found in the top-level
  directory of this distribution and at:

    https://code.devalot.com/open/openid-connect

  No part of this package, including this file, may be copied,
  modified, propagated, or distributed except according to the terms
  contained in the LICENSE file.

License: BSD-2-Clause

-}
module OpenID.Connect.JSON
  ( GenericJSON(..)
  , ErrorResponse(..)
  , (:*:)(..)
  , Words(..)
  , fromWords
  , toWords
  , URI(..)
  , Aeson.ToJSON
  , Aeson.FromJSON
  ) where

--------------------------------------------------------------------------------
import Control.Category ((>>>))
import Control.Monad (MonadPlus(..))
import Data.Aeson as Aeson
import Data.Aeson.Encoding as Aeson
import Data.Bifunctor (bimap)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Text (Text)
import qualified Data.Text as Text
import GHC.Generics (Generic, Rep)
import qualified Network.URI as Network

--------------------------------------------------------------------------------
-- | Type wrapper for automatic JSON deriving.
newtype GenericJSON a = GenericJSON
  { GenericJSON a -> a
genericJSON :: a }

--------------------------------------------------------------------------------
-- | Default JSON decoding/encoding options.
aesonOptions :: Aeson.Options
aesonOptions :: Options
aesonOptions = Options
Aeson.defaultOptions
    { fieldLabelModifier :: String -> String
Aeson.fieldLabelModifier     = String -> String
snakeCase
    , constructorTagModifier :: String -> String
Aeson.constructorTagModifier = String -> String
snakeCase
    , allNullaryToStringTag :: Bool
Aeson.allNullaryToStringTag  = Bool
True
    , omitNothingFields :: Bool
Aeson.omitNothingFields      = Bool
True
    }
  where
    snakeCase :: String -> String
snakeCase = Char -> String -> String
Aeson.camelTo2 Char
'_' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_')

instance ( Generic a
         , Aeson.GToJSON Aeson.Zero (Rep a)
         , Aeson.GToEncoding Aeson.Zero (Rep a)
         ) =>
  ToJSON (GenericJSON a) where
    toJSON :: GenericJSON a -> Value
toJSON     = Options -> a -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
Aeson.genericToJSON Options
aesonOptions     (a -> Value) -> (GenericJSON a -> a) -> GenericJSON a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericJSON a -> a
forall a. GenericJSON a -> a
genericJSON
    toEncoding :: GenericJSON a -> Encoding
toEncoding = Options -> a -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
Aeson.genericToEncoding Options
aesonOptions (a -> Encoding)
-> (GenericJSON a -> a) -> GenericJSON a -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericJSON a -> a
forall a. GenericJSON a -> a
genericJSON

instance ( Generic a
         , Aeson.GFromJSON Aeson.Zero (Rep a)
         ) =>
  FromJSON (GenericJSON a) where
    parseJSON :: Value -> Parser (GenericJSON a)
parseJSON = (a -> GenericJSON a) -> Parser a -> Parser (GenericJSON a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> GenericJSON a
forall a. a -> GenericJSON a
GenericJSON (Parser a -> Parser (GenericJSON a))
-> (Value -> Parser a) -> Value -> Parser (GenericJSON a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> Value -> Parser a
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
Aeson.genericParseJSON Options
aesonOptions

--------------------------------------------------------------------------------
-- | A provider response that indicates an error as described in OAuth
-- 2.0 Bearer Token Usage (RFC 6750).
--
-- @since 0.1.0.0
data ErrorResponse = ErrorResponse
  { ErrorResponse -> Text
errorCode        :: Text
  , ErrorResponse -> Maybe Text
errorDescription :: Maybe Text
  }
  deriving stock Int -> ErrorResponse -> String -> String
[ErrorResponse] -> String -> String
ErrorResponse -> String
(Int -> ErrorResponse -> String -> String)
-> (ErrorResponse -> String)
-> ([ErrorResponse] -> String -> String)
-> Show ErrorResponse
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ErrorResponse] -> String -> String
$cshowList :: [ErrorResponse] -> String -> String
show :: ErrorResponse -> String
$cshow :: ErrorResponse -> String
showsPrec :: Int -> ErrorResponse -> String -> String
$cshowsPrec :: Int -> ErrorResponse -> String -> String
Show

instance ToJSON ErrorResponse where
  toJSON :: ErrorResponse -> Value
toJSON ErrorResponse{Maybe Text
Text
errorDescription :: Maybe Text
errorCode :: Text
errorDescription :: ErrorResponse -> Maybe Text
errorCode :: ErrorResponse -> Text
..} = [Pair] -> Value
Aeson.object
    [ Key
"error" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
errorCode
    , Key
"error_description" Key -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
errorDescription
    ]
  toEncoding :: ErrorResponse -> Encoding
toEncoding ErrorResponse{Maybe Text
Text
errorDescription :: Maybe Text
errorCode :: Text
errorDescription :: ErrorResponse -> Maybe Text
errorCode :: ErrorResponse -> Text
..} = Series -> Encoding
Aeson.pairs
    ( Key
"error" Key -> Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
errorCode Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Key
"error_description" Key -> Maybe Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
errorDescription)

instance FromJSON ErrorResponse where
  parseJSON :: Value -> Parser ErrorResponse
parseJSON = String
-> (Object -> Parser ErrorResponse)
-> Value
-> Parser ErrorResponse
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Error Response" ((Object -> Parser ErrorResponse) -> Value -> Parser ErrorResponse)
-> (Object -> Parser ErrorResponse)
-> Value
-> Parser ErrorResponse
forall a b. (a -> b) -> a -> b
$ \Object
v ->
    Text -> Maybe Text -> ErrorResponse
ErrorResponse
      (Text -> Maybe Text -> ErrorResponse)
-> Parser Text -> Parser (Maybe Text -> ErrorResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.:  Key
"error"
      Parser (Maybe Text -> ErrorResponse)
-> Parser (Maybe Text) -> Parser ErrorResponse
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"error_description"

--------------------------------------------------------------------------------
-- | Join two types together so they work with the same JSON document.
newtype (:*:) a b = Join
  { (a :*: b) -> (a, b)
getProduct :: (a, b) }

instance (ToJSON a, ToJSON b) => ToJSON (a :*: b) where
  toJSON :: (a :*: b) -> Value
toJSON a :*: b
prod =
    case (a -> Value) -> (b -> Value) -> (a, b) -> (Value, Value)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> Value
forall a. ToJSON a => a -> Value
toJSON b -> Value
forall a. ToJSON a => a -> Value
toJSON ((a :*: b) -> (a, b)
forall a b. (a :*: b) -> (a, b)
getProduct a :*: b
prod) of
      (Aeson.Object Object
x, Aeson.Object Object
y) -> Object -> Value
Aeson.Object (Object
x Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
<> Object
y)
      (Value
x, Value
_)                           -> Value
x

instance (FromJSON a, FromJSON b) => FromJSON (a :*: b) where
  parseJSON :: Value -> Parser (a :*: b)
parseJSON Value
v = ((a, b) -> a :*: b) -> Parser (a, b) -> Parser (a :*: b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, b) -> a :*: b
forall a b. (a, b) -> a :*: b
Join ((,) (a -> b -> (a, b)) -> Parser a -> Parser (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v Parser (b -> (a, b)) -> Parser b -> Parser (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser b
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v)

--------------------------------------------------------------------------------
-- | Space separated list of words.
--
-- @since 0.1.0.0
newtype Words = Words
  { Words -> NonEmpty Text
toWordList :: NonEmpty Text
  }
  deriving stock ((forall x. Words -> Rep Words x)
-> (forall x. Rep Words x -> Words) -> Generic Words
forall x. Rep Words x -> Words
forall x. Words -> Rep Words x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Words x -> Words
$cfrom :: forall x. Words -> Rep Words x
Generic, Int -> Words -> String -> String
[Words] -> String -> String
Words -> String
(Int -> Words -> String -> String)
-> (Words -> String) -> ([Words] -> String -> String) -> Show Words
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Words] -> String -> String
$cshowList :: [Words] -> String -> String
show :: Words -> String
$cshow :: Words -> String
showsPrec :: Int -> Words -> String -> String
$cshowsPrec :: Int -> Words -> String -> String
Show)
  deriving newtype b -> Words -> Words
NonEmpty Words -> Words
Words -> Words -> Words
(Words -> Words -> Words)
-> (NonEmpty Words -> Words)
-> (forall b. Integral b => b -> Words -> Words)
-> Semigroup Words
forall b. Integral b => b -> Words -> Words
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> Words -> Words
$cstimes :: forall b. Integral b => b -> Words -> Words
sconcat :: NonEmpty Words -> Words
$csconcat :: NonEmpty Words -> Words
<> :: Words -> Words -> Words
$c<> :: Words -> Words -> Words
Semigroup

instance ToJSON Words where
  toJSON :: Words -> Value
toJSON = Words -> Text
fromWords (Words -> Text) -> (Text -> Value) -> Words -> Value
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Text -> Value
forall a. ToJSON a => a -> Value
toJSON
  toEncoding :: Words -> Encoding
toEncoding = Words -> Text
fromWords (Words -> Text) -> (Text -> Encoding) -> Words -> Encoding
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Text -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding

instance FromJSON Words where
  parseJSON :: Value -> Parser Words
parseJSON = String -> (Text -> Parser Words) -> Value -> Parser Words
forall a. String -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText String
"Space separated words" Text -> Parser Words
forall (m :: * -> *). MonadPlus m => Text -> m Words
toWords

--------------------------------------------------------------------------------
-- | Encode a list of words into 'Text'.
--
-- @since 0.1.0.0
fromWords :: Words -> Text
fromWords :: Words -> Text
fromWords = Words -> NonEmpty Text
toWordList
        (Words -> NonEmpty Text)
-> (NonEmpty Text -> Text) -> Words -> Text
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> NonEmpty Text -> NonEmpty Text
forall a. Eq a => NonEmpty a -> NonEmpty a
NonEmpty.nub
        (NonEmpty Text -> NonEmpty Text)
-> (NonEmpty Text -> Text) -> NonEmpty Text -> Text
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NonEmpty.toList
        (NonEmpty Text -> [Text])
-> ([Text] -> Text) -> NonEmpty Text -> Text
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> [Text] -> Text
Text.unwords

--------------------------------------------------------------------------------
-- | Decode a list of words from 'Text'.
--
-- @since 0.1.0.0
toWords :: MonadPlus m => Text -> m Words
toWords :: Text -> m Words
toWords = Text -> [Text]
Text.words (Text -> [Text]) -> ([Text] -> m Words) -> Text -> m Words
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
  [] -> m Words
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  [Text]
xs -> Words -> m Words
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty Text -> Words
Words (NonEmpty Text -> Words) -> NonEmpty Text -> Words
forall a b. (a -> b) -> a -> b
$ [Text] -> NonEmpty Text
forall a. [a] -> NonEmpty a
NonEmpty.fromList [Text]
xs)

--------------------------------------------------------------------------------
-- | A wrapper around the "Network.URI" type that supports 'ToJSON'
-- and 'FromJSON'.
--
-- @since 0.1.0.0
newtype URI = URI
  { URI -> URI
getURI :: Network.URI }
  deriving newtype (Int -> URI -> String -> String
[URI] -> String -> String
URI -> String
(Int -> URI -> String -> String)
-> (URI -> String) -> ([URI] -> String -> String) -> Show URI
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [URI] -> String -> String
$cshowList :: [URI] -> String -> String
show :: URI -> String
$cshow :: URI -> String
showsPrec :: Int -> URI -> String -> String
$cshowsPrec :: Int -> URI -> String -> String
Show, URI -> URI -> Bool
(URI -> URI -> Bool) -> (URI -> URI -> Bool) -> Eq URI
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: URI -> URI -> Bool
$c/= :: URI -> URI -> Bool
== :: URI -> URI -> Bool
$c== :: URI -> URI -> Bool
Eq)

instance ToJSON URI where
  toJSON :: URI -> Value
toJSON URI
u = String -> Value
forall a. ToJSON a => a -> Value
toJSON ((String -> String) -> URI -> String -> String
Network.uriToString String -> String
forall a. a -> a
id (URI -> URI
getURI URI
u) [])
  toEncoding :: URI -> Encoding
toEncoding URI
u = String -> Encoding
forall a. String -> Encoding' a
Aeson.string ((String -> String) -> URI -> String -> String
Network.uriToString String -> String
forall a. a -> a
id (URI -> URI
getURI URI
u) [])

instance FromJSON URI where
  parseJSON :: Value -> Parser URI
parseJSON = String -> (Text -> Parser URI) -> Value -> Parser URI
forall a. String -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText String
"URI" Text -> Parser URI
go
    where
      go :: Text -> Parser URI
go = Parser URI -> (URI -> Parser URI) -> Maybe URI -> Parser URI
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Parser URI
forall (m :: * -> *) a. MonadPlus m => m a
mzero (URI -> Parser URI
forall (f :: * -> *) a. Applicative f => a -> f a
pure (URI -> Parser URI) -> (URI -> URI) -> URI -> Parser URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> URI
URI) (Maybe URI -> Parser URI)
-> (Text -> Maybe URI) -> Text -> Parser URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
             String -> Maybe URI
Network.parseURI (String -> Maybe URI) -> (Text -> String) -> Text -> Maybe URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
               Text -> String
Text.unpack