module Web.Authenticate.Rpxnow
( Identifier (..)
, authenticate
, AuthenticateException (..)
) where
import Data.Aeson
import Network.HTTP.Enumerator
import "transformers" Control.Monad.IO.Class
import Control.Failure
import Data.Maybe
import Control.Monad
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
import Control.Exception (throwIO)
import Web.Authenticate.Internal
import Data.Data (Data)
import Data.Typeable (Typeable)
import Data.Attoparsec.Lazy (parse)
import qualified Data.Attoparsec.Lazy as AT
import Data.Text (Text)
import qualified Data.Aeson.Types
import qualified Data.Map as Map
import Control.Applicative ((<$>), (<*>))
data Identifier = Identifier
{ identifier :: Text
, extraData :: [(Text, Text)]
}
deriving (Eq, Ord, Read, Show, Data, Typeable)
authenticate :: (MonadIO m,
Failure HttpException m,
Failure AuthenticateException m)
=> String
-> String
-> m Identifier
authenticate apiKey token = do
let body = L.fromChunks
[ "apiKey="
, S.pack apiKey
, "&token="
, S.pack token
]
req' <- parseUrl "https://rpxnow.com"
let req =
req'
{ method = "POST"
, path = "api/v2/auth_info"
, requestHeaders =
[ ("Content-Type", "application/x-www-form-urlencoded")
]
, requestBody = RequestBodyLBS body
}
res <- liftIO $ withManager $ httpLbsRedirect req
let b = responseBody res
unless (200 <= statusCode res && statusCode res < 300) $
liftIO $ throwIO $ StatusCodeException (statusCode res) b
o <- unResult $ parse json b
let mstat = flip Data.Aeson.Types.parse o $ \v ->
case v of
Object m -> m .: "stat"
_ -> mzero
case mstat of
Success "ok" -> return ()
Success stat -> failure $ RpxnowException $
"Rpxnow login not accepted: " ++ stat ++ "\n" ++ L.unpack b
_ -> failure $ RpxnowException "Now stat value found on Rpxnow response"
case Data.Aeson.Types.parse parseProfile o of
Success x -> return x
Error e -> failure $ RpxnowException $ "Unable to parse Rpxnow response: " ++ e
unResult :: Failure AuthenticateException m => AT.Result a -> m a
unResult = either (failure . RpxnowException) return . AT.eitherResult
parseProfile :: Value -> Data.Aeson.Types.Parser Identifier
parseProfile (Object m) = do
profile <- m .: "profile"
Identifier
<$> (profile .: "identifier")
<*> return (mapMaybe go (Map.toList profile))
where
go ("identifier", _) = Nothing
go (k, String v) = Just (k, v)
go _ = Nothing
parseProfile _ = mzero