{-# 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