{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
-- |
-- HTTP Redirect Binding
--
-- <https://docs.oasis-open.org/security/saml/v2.0/saml-bindings-2.0-os.pdf saml-bindings-2.0-os> §3.4
module SAML2.Bindings.HTTPRedirect 
  ( encodeQuery
  , encodeHeaders
  , decodeURI
  ) where

import qualified Codec.Compression.Zlib.Raw as DEFLATE
import Control.Lens ((^.), (.~))
import Control.Monad (unless)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64.Lazy as Base64
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as BSL
import Data.Maybe (fromMaybe, maybeToList)
import Data.Monoid ((<>))
import Data.Proxy (Proxy(..))
import Network.HTTP.Types.Header (ResponseHeaders, hLocation, hCacheControl, hPragma)
import Network.HTTP.Types.URI (Query, renderQuery, urlDecode)
import Network.HTTP.Types.QueryLike (toQuery)
import Network.URI (URI(uriPath), nullURI, uriQuery, parseURIReference)

import SAML2.Lens
import SAML2.XML
import qualified SAML2.XML.Signature as DS
import SAML2.Core.Namespaces
import SAML2.Core.Versioning
import qualified SAML2.Core.Protocols as SAMLP
import SAML2.Bindings.General
import SAML2.Bindings.Internal

data Encoding
  = EncodingDEFLATE
  deriving (Encoding -> Encoding -> Bool
(Encoding -> Encoding -> Bool)
-> (Encoding -> Encoding -> Bool) -> Eq Encoding
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Encoding -> Encoding -> Bool
$c/= :: Encoding -> Encoding -> Bool
== :: Encoding -> Encoding -> Bool
$c== :: Encoding -> Encoding -> Bool
Eq, Encoding
Encoding -> Encoding -> Bounded Encoding
forall a. a -> a -> Bounded a
maxBound :: Encoding
$cmaxBound :: Encoding
minBound :: Encoding
$cminBound :: Encoding
Bounded, Int -> Encoding
Encoding -> Int
Encoding -> [Encoding]
Encoding -> Encoding
Encoding -> Encoding -> [Encoding]
Encoding -> Encoding -> Encoding -> [Encoding]
(Encoding -> Encoding)
-> (Encoding -> Encoding)
-> (Int -> Encoding)
-> (Encoding -> Int)
-> (Encoding -> [Encoding])
-> (Encoding -> Encoding -> [Encoding])
-> (Encoding -> Encoding -> [Encoding])
-> (Encoding -> Encoding -> Encoding -> [Encoding])
-> Enum Encoding
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Encoding -> Encoding -> Encoding -> [Encoding]
$cenumFromThenTo :: Encoding -> Encoding -> Encoding -> [Encoding]
enumFromTo :: Encoding -> Encoding -> [Encoding]
$cenumFromTo :: Encoding -> Encoding -> [Encoding]
enumFromThen :: Encoding -> Encoding -> [Encoding]
$cenumFromThen :: Encoding -> Encoding -> [Encoding]
enumFrom :: Encoding -> [Encoding]
$cenumFrom :: Encoding -> [Encoding]
fromEnum :: Encoding -> Int
$cfromEnum :: Encoding -> Int
toEnum :: Int -> Encoding
$ctoEnum :: Int -> Encoding
pred :: Encoding -> Encoding
$cpred :: Encoding -> Encoding
succ :: Encoding -> Encoding
$csucc :: Encoding -> Encoding
Enum, Int -> Encoding -> ShowS
[Encoding] -> ShowS
Encoding -> String
(Int -> Encoding -> ShowS)
-> (Encoding -> String) -> ([Encoding] -> ShowS) -> Show Encoding
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Encoding] -> ShowS
$cshowList :: [Encoding] -> ShowS
show :: Encoding -> String
$cshow :: Encoding -> String
showsPrec :: Int -> Encoding -> ShowS
$cshowsPrec :: Int -> Encoding -> ShowS
Show)

instance Identifiable URI Encoding where
  identifier :: Encoding -> URI
identifier = String -> (SAMLVersion, String) -> URI
samlURNIdentifier String
"bindings:URL-Encoding" ((SAMLVersion, String) -> URI)
-> (Encoding -> (SAMLVersion, String)) -> Encoding -> URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoding -> (SAMLVersion, String)
forall b. IsString b => Encoding -> (SAMLVersion, b)
f where
    f :: Encoding -> (SAMLVersion, b)
f Encoding
EncodingDEFLATE = (SAMLVersion
SAML20, b
"DEFLATE")

paramSAML :: Bool -> BS.ByteString
paramSAML :: Bool -> ByteString
paramSAML = Bool -> ByteString
forall a. IsString a => Bool -> a
protocolParameter

paramRelayState, paramSignature, paramSignatureAlgorithm, paramEncoding :: BS.ByteString
paramRelayState :: ByteString
paramRelayState = ByteString
forall a. IsString a => a
relayStateParameter
paramSignature :: ByteString
paramSignature = ByteString
"Signature"
paramSignatureAlgorithm :: ByteString
paramSignatureAlgorithm = ByteString
"SigAlg"
paramEncoding :: ByteString
paramEncoding = ByteString
"SAMLEncoding"

encodeQuery :: SAMLP.SAMLProtocol a => Maybe DS.SigningKey -> a -> IO Query
encodeQuery :: Maybe SigningKey -> a -> IO Query
encodeQuery Maybe SigningKey
sk a
p = case Maybe SigningKey
sk of
  Maybe SigningKey
Nothing -> Query -> IO Query
forall (m :: * -> *) a. Monad m => a -> m a
return Query
sq
  Just SigningKey
k -> do
    let sq' :: Query
sq' = Query
sq Query -> Query -> Query
forall a. [a] -> [a] -> [a]
++ [(ByteString, String)] -> Query
forall a. QueryLike a => a -> Query
toQuery [(ByteString
paramSignatureAlgorithm, URI -> String
forall a. Show a => a -> String
show (URI -> String) -> URI -> String
forall a b. (a -> b) -> a -> b
$ SignatureAlgorithm -> URI
forall b a. Identifiable b a => a -> b
identifier (SignatureAlgorithm -> URI) -> SignatureAlgorithm -> URI
forall a b. (a -> b) -> a -> b
$ SigningKey -> SignatureAlgorithm
DS.signingKeySignatureAlgorithm SigningKey
k)]
    ByteString
sig <- SigningKey -> ByteString -> IO ByteString
DS.signBase64 SigningKey
k (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Bool -> Query -> ByteString
renderQuery Bool
False Query
sq'
    Query -> IO Query
forall (m :: * -> *) a. Monad m => a -> m a
return (Query -> IO Query) -> Query -> IO Query
forall a b. (a -> b) -> a -> b
$ Query
sq' Query -> Query -> Query
forall a. [a] -> [a] -> [a]
++ [(ByteString, ByteString)] -> Query
forall a. QueryLike a => a -> Query
toQuery [(ByteString
paramSignature, ByteString
sig)]
  where
  p' :: a
p' = (ProtocolType -> Identity ProtocolType) -> a -> Identity a
forall a. SAMLProtocol a => Lens' a ProtocolType
SAMLP.samlProtocol' ((ProtocolType -> Identity ProtocolType) -> a -> Identity a)
-> ((Maybe Signature -> Identity (Maybe Signature))
    -> ProtocolType -> Identity ProtocolType)
-> (Maybe Signature -> Identity (Maybe Signature))
-> a
-> Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. $(fieldLens 'SAMLP.protocolSignature) ((Maybe Signature -> Identity (Maybe Signature))
 -> a -> Identity a)
-> Maybe Signature -> a -> a
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe Signature
forall a. Maybe a
Nothing (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a
p
  pv :: ByteString
pv = ByteString -> ByteString
Base64.encode
    (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ CompressParams -> ByteString -> ByteString
DEFLATE.compressWith CompressParams
DEFLATE.defaultCompressParams{ compressLevel :: CompressionLevel
DEFLATE.compressLevel = CompressionLevel
DEFLATE.bestCompression }
    (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. XmlPickler a => a -> ByteString
samlToXML a
p'
  sq :: Query
sq = [(ByteString, ByteString)] -> Query
forall a. QueryLike a => a -> Query
toQuery ([(ByteString, ByteString)] -> Query)
-> [(ByteString, ByteString)] -> Query
forall a b. (a -> b) -> a -> b
$ 
    (Bool -> ByteString
paramSAML (Bool -> ByteString) -> Bool -> ByteString
forall a b. (a -> b) -> a -> b
$ a -> Bool
forall a. SAMLProtocol a => a -> Bool
SAMLP.isSAMLResponse a
p, ByteString -> ByteString
BSL.toStrict ByteString
pv)
    (ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
: Maybe (ByteString, ByteString) -> [(ByteString, ByteString)]
forall a. Maybe a -> [a]
maybeToList ((ByteString
paramRelayState, ) (ByteString -> (ByteString, ByteString))
-> Maybe ByteString -> Maybe (ByteString, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProtocolType -> Maybe ByteString
SAMLP.relayState (a
p' a -> Getting ProtocolType a ProtocolType -> ProtocolType
forall s a. s -> Getting a s a -> a
^. Getting ProtocolType a ProtocolType
forall a. SAMLProtocol a => Lens' a ProtocolType
SAMLP.samlProtocol'))

httpHeaders :: ResponseHeaders
httpHeaders :: ResponseHeaders
httpHeaders =
  [ (HeaderName
hCacheControl, ByteString
"no-cache,no-store")
  , (HeaderName
hPragma,       ByteString
"no cache")
  ]

encodeHeaders :: SAMLP.SAMLProtocol a => Maybe DS.SigningKey -> a -> IO ResponseHeaders
encodeHeaders :: Maybe SigningKey -> a -> IO ResponseHeaders
encodeHeaders Maybe SigningKey
sk a
p = do
  Query
q <- Maybe SigningKey -> a -> IO Query
forall a. SAMLProtocol a => Maybe SigningKey -> a -> IO Query
encodeQuery Maybe SigningKey
sk a
p
  ResponseHeaders -> IO ResponseHeaders
forall (m :: * -> *) a. Monad m => a -> m a
return (ResponseHeaders -> IO ResponseHeaders)
-> ResponseHeaders -> IO ResponseHeaders
forall a b. (a -> b) -> a -> b
$
    (HeaderName
hLocation, String -> ByteString
BSC.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ URI -> String
forall a. Show a => a -> String
show (URI -> Maybe URI -> URI
forall a. a -> Maybe a -> a
fromMaybe URI
nullURI Maybe URI
d){ uriQuery :: String
uriQuery = ByteString -> String
BSC.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Bool -> Query -> ByteString
renderQuery Bool
True Query
q })
    (HeaderName, ByteString) -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: ResponseHeaders
httpHeaders
  where
  d :: Maybe URI
d = ProtocolType -> Maybe URI
SAMLP.protocolDestination (ProtocolType -> Maybe URI) -> ProtocolType -> Maybe URI
forall a b. (a -> b) -> a -> b
$ a
p a -> Getting ProtocolType a ProtocolType -> ProtocolType
forall s a. s -> Getting a s a -> a
^. Getting ProtocolType a ProtocolType
forall a. SAMLProtocol a => Lens' a ProtocolType
SAMLP.samlProtocol'

decodeURI :: forall a . SAMLP.SAMLProtocol a => DS.PublicKeys -> URI -> IO a
decodeURI :: PublicKeys -> URI -> IO a
decodeURI PublicKeys
pk URI
ru = do
  (ByteString, ByteString)
pq <- IO (ByteString, ByteString)
-> ((ByteString, ByteString) -> IO (ByteString, ByteString))
-> Maybe (ByteString, ByteString)
-> IO (ByteString, ByteString)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO (ByteString, ByteString)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"SAML parameter missing") (ByteString, ByteString) -> IO (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ByteString, ByteString) -> IO (ByteString, ByteString))
-> Maybe (ByteString, ByteString) -> IO (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ Proxy a
-> (ByteString -> Maybe (ByteString, ByteString))
-> Maybe (ByteString, ByteString)
forall m p a.
(SAMLProtocol m, IsString p) =>
Proxy m -> (p -> Maybe a) -> Maybe a
lookupProtocolParameter (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a) ByteString -> Maybe (ByteString, ByteString)
ql
  ByteString
pd <- case Identified URI Encoding
enc of
    Identified Encoding
EncodingDEFLATE ->
      ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
DEFLATE.decompress (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
Base64.decodeLenient (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst (ByteString, ByteString)
pq
    Identified URI Encoding
_ -> String -> IO ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String
"Unsupported HTTP redirect encoding: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Identified URI Encoding -> String
forall a. Show a => a -> String
show Identified URI Encoding
enc
  a
p <- (String -> IO a) -> (a -> IO a) -> Either String a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a -> IO a) -> Either String a -> IO a
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String a
forall a. XmlPickler a => ByteString -> Either String a
xmlToSAML ByteString
pd
  case ByteString -> Maybe (ByteString, ByteString)
ql ByteString
paramSignatureAlgorithm of
    Just (ByteString
sav, ByteString
sas) -> do
      Maybe Bool -> IO ()
forall (m :: * -> *). MonadFail m => Maybe Bool -> m ()
sigres (Maybe Bool -> IO ()) -> Maybe Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ PublicKeys
-> IdentifiedURI SignatureAlgorithm
-> ByteString
-> ByteString
-> Maybe Bool
DS.verifyBase64 PublicKeys
pk (URI -> IdentifiedURI SignatureAlgorithm
forall b a. Identifiable b a => b -> Identified b a
reidentify (URI -> IdentifiedURI SignatureAlgorithm)
-> URI -> IdentifiedURI SignatureAlgorithm
forall a b. (a -> b) -> a -> b
$ ByteString -> URI
puri ByteString
sav)
        (((ByteString, ByteString) -> ByteString)
-> Maybe (ByteString, ByteString) -> ByteString
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst (Maybe (ByteString, ByteString) -> ByteString)
-> Maybe (ByteString, ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe (ByteString, ByteString)
ql ByteString
paramSignature)
        ((ByteString, ByteString) -> ByteString
forall a b. (a, b) -> b
snd (ByteString, ByteString)
pq ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ((ByteString, ByteString) -> ByteString)
-> Maybe (ByteString, ByteString) -> ByteString
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Char -> ByteString -> ByteString
BSC.cons Char
'&' (ByteString -> ByteString)
-> ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> b
snd) Maybe (ByteString, ByteString)
rsq ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Char -> ByteString -> ByteString
BSC.cons Char
'&' ByteString
sas)
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ProtocolType -> Maybe URI
SAMLP.protocolDestination (a
p a -> Getting ProtocolType a ProtocolType -> ProtocolType
forall s a. s -> Getting a s a -> a
^. Getting ProtocolType a ProtocolType
forall a. SAMLProtocol a => Lens' a ProtocolType
SAMLP.samlProtocol') Maybe URI -> Maybe URI -> Bool
forall a. Eq a => a -> a -> Bool
== URI -> Maybe URI
forall a. a -> Maybe a
Just URI
ru{ uriQuery :: String
uriQuery = String
"" }) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Destination incorrect"
    Maybe (ByteString, ByteString)
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ (ProtocolType -> Identity ProtocolType) -> a -> Identity a
forall a. SAMLProtocol a => Lens' a ProtocolType
SAMLP.samlProtocol' ((ProtocolType -> Identity ProtocolType) -> a -> Identity a)
-> ((Maybe ByteString -> Identity (Maybe ByteString))
    -> ProtocolType -> Identity ProtocolType)
-> (Maybe ByteString -> Identity (Maybe ByteString))
-> a
-> Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. $(fieldLens 'SAMLP.relayState) ((Maybe ByteString -> Identity (Maybe ByteString))
 -> a -> Identity a)
-> Maybe ByteString -> a -> a
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ((ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ByteString) -> ByteString)
-> Maybe (ByteString, ByteString) -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (ByteString, ByteString)
rsq) (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a
p
  where
  qs :: ByteString
qs = String -> ByteString
BSC.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ URI -> String
uriQuery URI
ru
  pqp :: ByteString -> (ByteString, (ByteString, ByteString))
pqp ByteString
s = (Bool -> ByteString -> ByteString
urlDecode Bool
True ByteString
k, (ByteString
-> ((Word8, ByteString) -> ByteString)
-> Maybe (Word8, ByteString)
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
BSC.empty (Bool -> ByteString -> ByteString
urlDecode Bool
True (ByteString -> ByteString)
-> ((Word8, ByteString) -> ByteString)
-> (Word8, ByteString)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8, ByteString) -> ByteString
forall a b. (a, b) -> b
snd) (Maybe (Word8, ByteString) -> ByteString)
-> Maybe (Word8, ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
v, ByteString
s)) where
    (ByteString
k, ByteString
v) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BSC.break (Char
'=' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) ByteString
s
  q :: [(ByteString, (ByteString, ByteString))]
q = (ByteString -> (ByteString, (ByteString, ByteString)))
-> [ByteString] -> [(ByteString, (ByteString, ByteString))]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> (ByteString, (ByteString, ByteString))
pqp ([ByteString] -> [(ByteString, (ByteString, ByteString))])
-> [ByteString] -> [(ByteString, (ByteString, ByteString))]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> [ByteString]
BSC.splitWith (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'&',Char
';']) (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ case ByteString -> Maybe (Char, ByteString)
BSC.uncons ByteString
qs of
    Just (Char
'?', ByteString
qs') -> ByteString
qs'
    Maybe (Char, ByteString)
_ -> ByteString
qs
  ql :: ByteString -> Maybe (ByteString, ByteString)
ql ByteString
v = ByteString
-> [(ByteString, (ByteString, ByteString))]
-> Maybe (ByteString, ByteString)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
v [(ByteString, (ByteString, ByteString))]
q
  puri :: ByteString -> URI
puri ByteString
bs = URI -> Maybe URI -> URI
forall a. a -> Maybe a -> a
fromMaybe URI
nullURI{ uriPath :: String
uriPath = String
s } (Maybe URI -> URI) -> Maybe URI -> URI
forall a b. (a -> b) -> a -> b
$ String -> Maybe URI
parseURIReference String
s where s :: String
s = ByteString -> String
BSC.unpack ByteString
bs
  enc :: Identified URI Encoding
enc = Identified URI Encoding
-> (URI -> Identified URI Encoding)
-> Maybe URI
-> Identified URI Encoding
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Encoding -> Identified URI Encoding
forall b a. a -> Identified b a
Identified Encoding
EncodingDEFLATE) URI -> Identified URI Encoding
forall b a. Identifiable b a => b -> Identified b a
reidentify (Maybe URI -> Identified URI Encoding)
-> Maybe URI -> Identified URI Encoding
forall a b. (a -> b) -> a -> b
$ ((ByteString, ByteString) -> URI)
-> Maybe (ByteString, ByteString) -> Maybe URI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> URI
puri (ByteString -> URI)
-> ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString)
-> URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst) (Maybe (ByteString, ByteString) -> Maybe URI)
-> Maybe (ByteString, ByteString) -> Maybe URI
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe (ByteString, ByteString)
ql ByteString
paramEncoding
  rsq :: Maybe (ByteString, ByteString)
rsq = ByteString -> Maybe (ByteString, ByteString)
ql ByteString
paramRelayState
  sigres :: Maybe Bool -> m ()
sigres (Just Bool
True) = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  sigres (Just Bool
False) = String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Signature verification failed"
  sigres Maybe Bool
Nothing = String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Could not verify signature"