{-# 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)
import Data.Aeson (json, Value (Object, String))
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 :: Text -> Text -> Manager -> m (Maybe Text)
checkAssertion Text
audience Text
assertion 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 String
"https://verifier.login.persona.org/verify"
    let req :: Request
req = [(ByteString, ByteString)] -> Request -> Request
urlEncodedBody
                [ (ByteString
"audience", Text -> ByteString
encodeUtf8 Text
audience)
                , (ByteString
"assertion", Text -> ByteString
encodeUtf8 Text
assertion)
                ] Request
req' { method :: ByteString
method = ByteString
"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 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