module Web.Authenticate.Rpxnow
( Identifier (..)
, authenticate
) where
import Data.Object
import Data.Object.Json
import Network.HTTP.Enumerator
import "transformers" Control.Monad.IO.Class
import Control.Failure
import Data.Maybe
import Web.Authenticate.OpenId (AuthenticateException (..))
import Control.Monad
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
import Control.Exception (throwIO)
data Identifier = Identifier
{ identifier :: String
, extraData :: [(String, String)]
}
authenticate :: (MonadIO m,
Failure HttpException m,
Failure InvalidUrlException m,
Failure AuthenticateException m,
Failure ObjectExtractError m,
Failure JsonDecodeError m)
=> String
-> String
-> m Identifier
authenticate apiKey token = do
let body = L.fromChunks
[ "apiKey="
, S.pack apiKey
, "&token="
, S.pack token
]
let req =
Request
{ method = "POST"
, secure = True
, host = "rpxnow.com"
, port = 443
, path = "api/v2/auth_info"
, queryString = []
, requestHeaders =
[ ("Content-Type", "application/x-www-form-urlencoded")
]
, requestBody = body
}
res <- httpLbsRedirect req
let b = responseBody res
unless (200 <= statusCode res && statusCode res < 300) $
liftIO $ throwIO $ HttpException (statusCode res) b
o <- decode $ S.concat $ L.toChunks b
m <- fromMapping o
stat <- lookupScalar "stat" m
unless (stat == "ok") $ failure $ AuthenticateException $
"Rpxnow login not accepted: " ++ stat ++ "\n" ++ L.unpack b
parseProfile m
parseProfile :: (Monad m, Failure ObjectExtractError m)
=> [(String, StringObject)] -> m Identifier
parseProfile m = do
profile <- lookupMapping "profile" m
ident <- lookupScalar "identifier" profile
let profile' = mapMaybe go profile
return $ Identifier ident profile'
where
go ("identifier", _) = Nothing
go (k, Scalar v) = Just (k, v)
go _ = Nothing