{-# 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
  , aesonOptions
  ) 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
  { forall a. 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
'_' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (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     = forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
Aeson.genericToJSON Options
aesonOptions     forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. GenericJSON a -> a
genericJSON
    toEncoding :: GenericJSON a -> Encoding
toEncoding = forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
Aeson.genericToEncoding Options
aesonOptions forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> GenericJSON a
GenericJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
errorCode
    , Key
"error_description" 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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
errorCode forall a. Semigroup a => a -> a -> a
<> Key
"error_description" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
errorDescription)

instance FromJSON ErrorResponse where
  parseJSON :: Value -> Parser ErrorResponse
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Error Response" forall a b. (a -> b) -> a -> b
$ \Object
v ->
    Text -> Maybe Text -> ErrorResponse
ErrorResponse
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.:  Key
"error"
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v 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
  { forall a b. (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 forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a. ToJSON a => a -> Value
toJSON forall a. ToJSON a => a -> Value
toJSON (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 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a :*: b
Join ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
v forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f 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. 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
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 NonEmpty Words -> Words
Words -> Words -> 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 :: forall b. Integral b => 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 forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a. ToJSON a => a -> Value
toJSON
  toEncoding :: Words -> Encoding
toEncoding = Words -> Text
fromWords forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a. ToJSON a => a -> Encoding
toEncoding

instance FromJSON Words where
  parseJSON :: Value -> Parser Words
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText String
"Space separated 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
        forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a. Eq a => NonEmpty a -> NonEmpty a
NonEmpty.nub
        forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a. NonEmpty a -> [a]
NonEmpty.toList
        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 :: forall (m :: * -> *). MonadPlus m => Text -> m Words
toWords = Text -> [Text]
Text.words forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
  [] -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
  [Text]
xs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty Text -> Words
Words forall a b. (a -> b) -> a -> b
$ 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
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
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 = forall a. ToJSON a => a -> Value
toJSON ((String -> String) -> URI -> String -> String
Network.uriToString forall a. a -> a
id (URI -> URI
getURI URI
u) [])
  toEncoding :: URI -> Encoding
toEncoding URI
u = forall a. String -> Encoding' a
Aeson.string ((String -> String) -> URI -> String -> String
Network.uriToString forall a. a -> a
id (URI -> URI
getURI URI
u) [])

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