115 lines
3.8 KiB
Haskell
115 lines
3.8 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE PackageImports #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE DeriveDataTypeable #-}
|
|
---------------------------------------------------------
|
|
--
|
|
-- Module : Web.Authenticate.Rpxnow
|
|
-- Copyright : Michael Snoyman
|
|
-- License : BSD3
|
|
--
|
|
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
|
-- Stability : Unstable
|
|
-- Portability : portable
|
|
--
|
|
-- Facilitates authentication with "http://rpxnow.com/".
|
|
--
|
|
---------------------------------------------------------
|
|
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 ((<$>), (<*>))
|
|
import Network.TLS (TLSCertificateUsage (CertificateUsageAccept))
|
|
|
|
-- | Information received from Rpxnow after a valid login.
|
|
data Identifier = Identifier
|
|
{ identifier :: Text
|
|
, extraData :: [(Text, Text)]
|
|
}
|
|
deriving (Eq, Ord, Read, Show, Data, Typeable)
|
|
|
|
-- | Attempt to log a user in.
|
|
authenticate :: (MonadIO m,
|
|
Failure HttpException m,
|
|
Failure AuthenticateException m)
|
|
=> String -- ^ API key given by RPXNOW.
|
|
-> String -- ^ Token passed by client.
|
|
-> 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 = RequestBodyLBS body
|
|
, checkCerts = const $ return CertificateUsageAccept
|
|
, proxy = Nothing
|
|
, rawBody = False
|
|
}
|
|
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
|
|
--m <- fromMapping o
|
|
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
|