{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- FUTUREWORK: disallow orphans.

module SAML2.WebSSO.Orphans where

import Control.Exception (assert)
import Control.Monad ((<=<))
import Data.Aeson
import Data.ByteString
import Data.ByteString.Builder
import Data.Schema as Schema
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Data.Text.Lazy qualified as TL
import Data.X509 as X509
import Data.Yaml.Aeson qualified as A
import SAML2.Util (normURI, parseURI', renderURI)
import Servant hiding (URI)
import System.Logger (Level (..))
import Text.XML.DSig
import URI.ByteString

instance FromJSON URI where
  parseJSON :: Value -> Parser URI
parseJSON = ((String -> Parser URI)
-> (URI -> Parser URI) -> Either String URI -> Parser URI
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser URI
forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
unerror (URI -> Parser URI
forall a. a -> Parser a
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
normURI) (Either String URI -> Parser URI)
-> (ST -> Either String URI) -> ST -> Parser URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST -> Either String URI
forall (m :: * -> *). MonadError String m => ST -> m URI
parseURI') (ST -> Parser URI) -> (Value -> Parser ST) -> Value -> Parser URI
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Value -> Parser ST
forall a. FromJSON a => Value -> Parser a
parseJSON
    where
      unerror :: a -> m a
unerror = String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> (a -> String) -> a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"could not parse config: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

instance ToJSON URI where
  toJSON :: URI -> Value
toJSON = ST -> Value
forall a. ToJSON a => a -> Value
toJSON (ST -> Value) -> (URI -> ST) -> URI -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> ST
renderURI

instance ToHttpApiData URI where
  toUrlPiece :: URI -> ST
toUrlPiece = URI -> ST
renderURI

instance FromHttpApiData URI where
  parseUrlPiece :: ST -> Either ST URI
parseUrlPiece = (String -> Either ST URI)
-> (URI -> Either ST URI) -> Either String URI -> Either ST URI
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ST -> Either ST URI
forall a b. a -> Either a b
Left (ST -> Either ST URI) -> (String -> ST) -> String -> Either ST URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ST
Text.pack) URI -> Either ST URI
forall a. a -> Either ST a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String URI -> Either ST URI)
-> (ST -> Either String URI) -> ST -> Either ST URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST -> Either String URI
forall (m :: * -> *). MonadError String m => ST -> m URI
parseURI' (ST -> Either ST URI)
-> (ST -> Either ST ST) -> ST -> Either ST URI
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ST -> Either ST ST
forall a. FromHttpApiData a => ST -> Either ST a
parseUrlPiece

instance Schema.ToSchema SignedCertificate where
  schema :: ValueSchema NamedSwaggerDoc SignedCertificate
schema = SignedCertificate -> ST
serialize (SignedCertificate -> ST)
-> SchemaP NamedSwaggerDoc Value Value ST SignedCertificate
-> ValueSchema NamedSwaggerDoc SignedCertificate
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
Schema..= ST
-> (ST -> Either String SignedCertificate)
-> SchemaP NamedSwaggerDoc Value Value ST SignedCertificate
forall a.
ST
-> (ST -> Either String a)
-> SchemaP NamedSwaggerDoc Value Value ST a
Schema.parsedText ST
"SignedCertificate" ST -> Either String SignedCertificate
parse
    where
      parse :: Text.Text -> Either String SignedCertificate
      parse :: ST -> Either String SignedCertificate
parse = Bool -> LT -> Either String SignedCertificate
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Bool -> LT -> m SignedCertificate
parseKeyInfo Bool
False (LT -> Either String SignedCertificate)
-> (ST -> LT) -> ST -> Either String SignedCertificate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST -> LT
TL.fromStrict

      serialize :: SignedCertificate -> Text.Text
      serialize :: SignedCertificate -> ST
serialize = LT -> ST
TL.toStrict (LT -> ST) -> (SignedCertificate -> LT) -> SignedCertificate -> ST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => SignedCertificate -> LT
SignedCertificate -> LT
renderKeyInfo

deriving via (Schema.Schema SignedCertificate) instance FromJSON SignedCertificate

deriving via (Schema.Schema SignedCertificate) instance ToJSON SignedCertificate

-- This can unfortunately not live in wire-api, because wire-api depends on
-- saml2-web-sso.
instance ToSchema URI where
  schema :: ValueSchema NamedSwaggerDoc URI
schema = URI -> ST
uriToText (URI -> ST)
-> SchemaP NamedSwaggerDoc Value Value ST ST
-> SchemaP NamedSwaggerDoc Value Value URI ST
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
Schema..= forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema @Text SchemaP NamedSwaggerDoc Value Value URI ST
-> (ST -> Parser URI) -> ValueSchema NamedSwaggerDoc URI
forall doc v w a b b'.
SchemaP doc v w a b -> (b -> Parser b') -> SchemaP doc v w a b'
`withParser` ST -> Parser URI
parseSchemaURI
    where
      uriToText :: URI -> Text
      uriToText :: URI -> ST
uriToText = ByteString -> ST
Text.decodeUtf8 (ByteString -> ST) -> (URI -> ByteString) -> URI -> ST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LazyByteString -> ByteString
toStrict (LazyByteString -> ByteString)
-> (URI -> LazyByteString) -> URI -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyByteString
toLazyByteString (Builder -> LazyByteString)
-> (URI -> Builder) -> URI -> LazyByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> Builder
forall a. URIRef a -> Builder
serializeURIRef

      parseSchemaURI :: Text -> A.Parser URI
      parseSchemaURI :: ST -> Parser URI
parseSchemaURI ST
uriText =
        (URIParseError -> Parser URI)
-> (URI -> Parser URI) -> Either URIParseError URI -> Parser URI
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
          (\URIParseError
e -> String -> Parser URI
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Failed to parse URI " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ST -> String
Text.unpack ST
uriText String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ URIParseError -> String
forall a. Show a => a -> String
show URIParseError
e))
          URI -> Parser URI
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          (Either URIParseError URI -> Parser URI)
-> Either URIParseError URI -> Parser URI
forall a b. (a -> b) -> a -> b
$ (URIParserOptions -> ByteString -> Either URIParseError URI
parseURI URIParserOptions
strictURIParserOptions (ByteString -> Either URIParseError URI)
-> (ST -> ByteString) -> ST -> Either URIParseError URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST -> ByteString
Text.encodeUtf8) ST
uriText

instance ToSchema Level where
  schema :: ValueSchema NamedSwaggerDoc Level
schema = Bool
-> ValueSchema NamedSwaggerDoc Level
-> ValueSchema NamedSwaggerDoc Level
forall a. HasCallStack => Bool -> a -> a
assert Bool
exhaustive (ValueSchema NamedSwaggerDoc Level
 -> ValueSchema NamedSwaggerDoc Level)
-> ValueSchema NamedSwaggerDoc Level
-> ValueSchema NamedSwaggerDoc Level
forall a b. (a -> b) -> a -> b
$ forall v doc a b.
(With v, HasEnum v doc) =>
ST
-> SchemaP [Value] v (Alt Maybe v) a b
-> SchemaP doc Value Value a b
enum @Text ST
"Level" (SchemaP [Value] ST (Alt Maybe ST) Level Level
 -> ValueSchema NamedSwaggerDoc Level)
-> SchemaP [Value] ST (Alt Maybe ST) Level Level
-> ValueSchema NamedSwaggerDoc Level
forall a b. (a -> b) -> a -> b
$ [SchemaP [Value] ST (Alt Maybe ST) Level Level]
-> SchemaP [Value] ST (Alt Maybe ST) Level Level
forall a. Monoid a => [a] -> a
mconcat ([SchemaP [Value] ST (Alt Maybe ST) Level Level]
 -> SchemaP [Value] ST (Alt Maybe ST) Level Level)
-> [SchemaP [Value] ST (Alt Maybe ST) Level Level]
-> SchemaP [Value] ST (Alt Maybe ST) Level Level
forall a b. (a -> b) -> a -> b
$ Level -> SchemaP [Value] ST (Alt Maybe ST) Level Level
forall {b}.
(Eq b, Show b) =>
b -> SchemaP [Value] ST (Alt Maybe ST) b b
el (Level -> SchemaP [Value] ST (Alt Maybe ST) Level Level)
-> [Level] -> [SchemaP [Value] ST (Alt Maybe ST) Level Level]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Level
forall a. Bounded a => a
minBound ..]
    where
      el :: b -> SchemaP [Value] ST (Alt Maybe ST) b b
el b
l = ST -> b -> SchemaP [Value] ST (Alt Maybe ST) b b
forall a b.
(ToJSON a, Eq a, Eq b) =>
a -> b -> SchemaP [Value] a (Alt Maybe a) b b
element (String -> ST
Text.pack (b -> String
forall a. Show a => a -> String
show b
l)) b
l

      exhaustive :: Bool
      exhaustive :: Bool
exhaustive = [Level
forall a. Bounded a => a
minBound ..] [Level] -> [Level] -> Bool
forall a. Eq a => a -> a -> Bool
== [Level
Trace, Level
Debug, Level
Info, Level
Warn, Level
System.Logger.Error, Level
Fatal]

deriving instance Enum Level

deriving instance Bounded Level

-- | Used in tests to have JSON as @extra@ in @IdPConfig extra@
instance Schema.ToSchema A.Value where
  schema :: ValueSchema NamedSwaggerDoc Value
schema =
    ST
-> SchemaP SwaggerDoc Value Value Value Value
-> ValueSchema NamedSwaggerDoc Value
forall doc doc' v m a b.
HasObject doc doc' =>
ST -> SchemaP doc v m a b -> SchemaP doc' v m a b
Schema.named (String -> ST
Text.pack String
"Value") (SchemaP SwaggerDoc Value Value Value Value
 -> ValueSchema NamedSwaggerDoc Value)
-> SchemaP SwaggerDoc Value Value Value Value
-> ValueSchema NamedSwaggerDoc Value
forall a b. (a -> b) -> a -> b
$
      Value -> Value
forall a. a -> a
id
        (Value -> Value)
-> SchemaP SwaggerDoc Value Value Value Value
-> SchemaP SwaggerDoc Value Value Value Value
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
Schema..= SchemaP SwaggerDoc Value Value Value Value
Schema.jsonValue