{-# 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
    Request
req' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 <- forall (m :: * -> *).
MonadIO m =>
Request -> Manager -> m (Response ByteString)
httpLbs Request
req Manager
manager
    let lbs :: ByteString
lbs = forall body. Response body -> body
responseBody Response ByteString
res
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall r. Result r -> Maybe r
maybeResult (forall a. Parser a -> ByteString -> Result a
parse Parser Value
json ByteString
lbs) 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 (forall v. Key -> KeyMap v -> Maybe v
Map.lookup Key
"status" Object
o, forall v. Key -> KeyMap v -> Maybe v
Map.lookup Key
"email" Object
o) of
            (Just (String Text
"okay"), Just (String Text
e)) -> forall a. a -> Maybe a
Just Text
e
            (Maybe Value, Maybe Value)
_ -> forall a. Maybe a
Nothing
    getEmail Value
_ = forall a. Maybe a
Nothing