{-# LANGUAGE OverloadedStrings #-}
module SAML2.WebSSO.Servant where
import Data.EitherR
import Data.Function
import Data.List (nubBy)
import Data.Map qualified as Map
import Data.Proxy
import Data.String.Conversions
import Network.HTTP.Media ((//))
import Network.HTTP.Types
import Network.HTTP.Types.Header qualified as HttpTypes
import Network.Wai hiding (Response)
import Network.Wai.Internal as Wai
import SAML2.WebSSO.XML
import Servant.API as Servant hiding (URI (..))
import Text.Hamlet.XML
import Text.XML
type GetRedir = Verb 'GET 307
type PostRedir = Verb 'POST 303
data XML
instance Accept XML where
contentType :: Proxy XML -> MediaType
contentType Proxy XML
Proxy = ByteString
"application" ByteString -> ByteString -> MediaType
// ByteString
"xml"
instance {-# OVERLAPPABLE #-} (HasXMLRoot a) => MimeRender XML a where
mimeRender :: Proxy XML -> a -> ByteString
mimeRender Proxy XML
Proxy = LT -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (LT -> ByteString) -> (a -> LT) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> LT
forall a. HasXMLRoot a => a -> LT
encode
instance {-# OVERLAPPABLE #-} (HasXMLRoot a) => MimeUnrender XML a where
mimeUnrender :: Proxy XML -> ByteString -> Either String a
mimeUnrender Proxy XML
Proxy = (String -> String) -> Either String a -> Either String a
forall a b r. (a -> b) -> Either a r -> Either b r
fmapL String -> String
forall a. Show a => a -> String
show (Either String a -> Either String a)
-> (ByteString -> Either String a) -> ByteString -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LT -> Either String a
forall (m :: * -> *) a.
(HasXMLRoot a, MonadError String m) =>
LT -> m a
decode (LT -> Either String a)
-> (ByteString -> LT) -> ByteString -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> LT
forall a b. ConvertibleStrings a b => a -> b
cs
data HTML
instance Accept HTML where
contentType :: Proxy HTML -> MediaType
contentType Proxy HTML
Proxy = ByteString
"text" ByteString -> ByteString -> MediaType
// ByteString
"html"
instance MimeRender HTML ST where
mimeRender :: Proxy HTML -> Text -> ByteString
mimeRender Proxy HTML
Proxy Text
msg =
[Node] -> ByteString
mkHtml
[xml|
<body>
<p>
#{msg}
|]
mkHtml :: [Node] -> LBS
mkHtml :: [Node] -> ByteString
mkHtml [Node]
nodes = RenderSettings -> Document -> ByteString
renderLBS RenderSettings
forall a. Default a => a
def Document
doc
where
doc :: Document
doc = Prologue -> Element -> [Miscellaneous] -> Document
Document ([Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
Prologue [] (Doctype -> Maybe Doctype
forall a. a -> Maybe a
Just Doctype
doctyp) []) Element
root []
doctyp :: Doctype
doctyp = Text -> Maybe ExternalID -> Doctype
Doctype Text
"html" (ExternalID -> Maybe ExternalID
forall a. a -> Maybe a
Just (ExternalID -> Maybe ExternalID) -> ExternalID -> Maybe ExternalID
forall a b. (a -> b) -> a -> b
$ Text -> Text -> ExternalID
PublicID Text
"-//W3C//DTD XHTML 1.1//EN" Text
"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd")
root :: Element
root = Name -> Map Name Text -> [Node] -> Element
Element Name
"html" Map Name Text
forall {k} {a}. (Ord k, IsString k, IsString a) => Map k a
rootattr [Node]
nodes
rootattr :: Map k a
rootattr = [(k, a)] -> Map k a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(k
"xmlns", a
"http://www.w3.org/1999/xhtml"), (k
"xml:lang", a
"en")]
setHttpCachePolicy :: Middleware
setHttpCachePolicy :: Middleware
setHttpCachePolicy Application
ap Request
rq Response -> IO ResponseReceived
respond = Application
ap Request
rq ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> (Response -> Response) -> Response -> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResponseHeaders -> Response -> Response
addHeadersToResponse ResponseHeaders
httpCachePolicy
where
httpCachePolicy :: HttpTypes.ResponseHeaders
httpCachePolicy :: ResponseHeaders
httpCachePolicy = [(HeaderName
"Cache-Control", ByteString
"no-cache, no-store"), (HeaderName
"Pragma", ByteString
"no-cache")]
addHeadersToResponse :: HttpTypes.ResponseHeaders -> Wai.Response -> Wai.Response
addHeadersToResponse :: ResponseHeaders -> Response -> Response
addHeadersToResponse ResponseHeaders
extraHeaders Response
resp = case Response
resp of
ResponseFile Status
status ResponseHeaders
hdrs String
filepath Maybe FilePart
part -> Status -> ResponseHeaders -> String -> Maybe FilePart -> Response
ResponseFile Status
status (ResponseHeaders -> ResponseHeaders
updH ResponseHeaders
hdrs) String
filepath Maybe FilePart
part
ResponseBuilder Status
status ResponseHeaders
hdrs Builder
builder -> Status -> ResponseHeaders -> Builder -> Response
ResponseBuilder Status
status (ResponseHeaders -> ResponseHeaders
updH ResponseHeaders
hdrs) Builder
builder
ResponseStream Status
status ResponseHeaders
hdrs StreamingBody
body -> Status -> ResponseHeaders -> StreamingBody -> Response
ResponseStream Status
status (ResponseHeaders -> ResponseHeaders
updH ResponseHeaders
hdrs) StreamingBody
body
ResponseRaw IO ByteString -> (ByteString -> IO ()) -> IO ()
action Response
resp' ->
(IO ByteString -> (ByteString -> IO ()) -> IO ())
-> Response -> Response
ResponseRaw IO ByteString -> (ByteString -> IO ()) -> IO ()
action (Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$
ResponseHeaders -> Response -> Response
addHeadersToResponse ResponseHeaders
extraHeaders Response
resp'
where
updH :: ResponseHeaders -> ResponseHeaders
updH ResponseHeaders
hdrs = ((HeaderName, ByteString) -> (HeaderName, ByteString) -> Bool)
-> ResponseHeaders -> ResponseHeaders
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
(==) (HeaderName -> HeaderName -> Bool)
-> ((HeaderName, ByteString) -> HeaderName)
-> (HeaderName, ByteString)
-> (HeaderName, ByteString)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (HeaderName, ByteString) -> HeaderName
forall a b. (a, b) -> a
fst) (ResponseHeaders -> ResponseHeaders)
-> ResponseHeaders -> ResponseHeaders
forall a b. (a -> b) -> a -> b
$ ResponseHeaders
extraHeaders ResponseHeaders -> ResponseHeaders -> ResponseHeaders
forall a. [a] -> [a] -> [a]
++ ResponseHeaders
hdrs