    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE CPP #-}
    module Web.Authenticate.BrowserId
        ( browserIdJs
        , checkAssertion
        ) where

    import Data.Text (Text)
    import Network.HTTP.Conduit (parseUrlThrow, responseBody, httpLbs, Manager, method, urlEncodedBody)
    #if MIN_VERSION_aeson(2,2,0)
    import Data.Aeson (Value (Object, String))
    import Data.Aeson.Parser (json)
    #else
    import Data.Aeson (json, Value (Object, String))
    #endif
    import Data.Attoparsec.Lazy (parse, maybeResult)
    #if MIN_VERSION_aeson(2,0,0)
    import qualified Data.Aeson.KeyMap as Map
    #else
    import qualified Data.HashMap.Lazy as Map
    #endif
    import Data.Text.Encoding (encodeUtf8)
    import Control.Monad.IO.Class (MonadIO, liftIO)

    -- | Location of the Javascript file hosted by browserid.org
    browserIdJs :: Text
    browserIdJs :: Text
    browserIdJs = Text
    "https://login.persona.org/include.js"

    checkAssertion :: MonadIO m
                   => Text -- ^ audience
                   -> Text -- ^ assertion
                   -> Manager
                   -> m (Maybe Text)
    checkAssertion :: forall (m :: * -> *).
    MonadIO m =>
    Text -> Text -> Manager -> m (Maybe Text)
    checkAssertion Text
    audience Text
    assertion Manager
    manager = do
        req' <- IO Request -> m Request
    forall a. IO a -> m a
    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 String
    "https://verifier.login.persona.org/verify"
        let req = [(ByteString, ByteString)] -> Request -> Request
    urlEncodedBody
                    [ (ByteString
    "audience", Text -> ByteString
    encodeUtf8 Text
    audience)
                    , (ByteString
    "assertion", Text -> ByteString
    encodeUtf8 Text
    assertion)
                    ] Request
    req' { method = "POST" }
        res <- httpLbs req manager
        let lbs = Response ByteString -> ByteString
    forall body. Response body -> body
    responseBody Response ByteString
    res
        return $ maybeResult (parse json lbs) >>= getEmail
      where
        getEmail :: Value -> Maybe Text
    getEmail (Object Object
    o) =
            case (Key -> Object -> Maybe Value
    forall v. Key -> KeyMap v -> Maybe v
    Map.lookup Key
    "status" Object
    o, Key -> Object -> Maybe Value
    forall v. Key -> KeyMap v -> Maybe v
    Map.lookup Key
    "email" Object
    o) of
                (Just (String Text
    "okay"), Just (String Text
    e)) -> Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    e
                (Maybe Value, Maybe Value)
    _ -> Maybe Text
    forall a. Maybe a
    Nothing
        getEmail Value
    _ = Maybe Text
    forall a. Maybe a
    Nothing