{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module Web.Authenticate.BrowserId
( browserIdJs
, checkAssertion
) where
import Data.Text (Text)
import Network.HTTP.Conduit (parseUrlThrow, responseBody, httpLbs, Manager, method, urlEncodedBody)
import Data.Aeson (json, Value (Object, String))
import Data.Attoparsec.Lazy (parse, maybeResult)
import qualified Data.HashMap.Lazy as Map
import Data.Text.Encoding (encodeUtf8)
import Control.Monad.IO.Class (MonadIO, liftIO)
browserIdJs :: Text
browserIdJs :: Text
browserIdJs = "https://login.persona.org/include.js"
checkAssertion :: MonadIO m
=> Text
-> Text
-> Manager
-> m (Maybe Text)
checkAssertion :: Text -> Text -> Manager -> m (Maybe Text)
checkAssertion audience :: Text
audience assertion :: Text
assertion manager :: Manager
manager = do
Request
req' <- IO Request -> m Request
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Request -> m Request) -> IO Request -> m Request
forall a b. (a -> b) -> a -> b
$ String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow "https://verifier.login.persona.org/verify"
let req :: Request
req = [(ByteString, ByteString)] -> Request -> Request
urlEncodedBody
[ ("audience", Text -> ByteString
encodeUtf8 Text
audience)
, ("assertion", Text -> ByteString
encodeUtf8 Text
assertion)
] Request
req' { method :: ByteString
method = "POST" }
Response ByteString
res <- Request -> Manager -> m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> Manager -> m (Response ByteString)
httpLbs Request
req Manager
manager
let lbs :: ByteString
lbs = Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
res
Maybe Text -> m (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> m (Maybe Text)) -> Maybe Text -> m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Result Value -> Maybe Value
forall r. Result r -> Maybe r
maybeResult (Parser Value -> ByteString -> Result Value
forall a. Parser a -> ByteString -> Result a
parse Parser Value
json ByteString
lbs) Maybe Value -> (Value -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Maybe Text
getEmail
where
getEmail :: Value -> Maybe Text
getEmail (Object o :: Object
o) =
case (Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup "status" Object
o, Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup "email" Object
o) of
(Just (String "okay"), Just (String e :: Text
e)) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
e
_ -> Maybe Text
forall a. Maybe a
Nothing
getEmail _ = Maybe Text
forall a. Maybe a
Nothing