{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-}
{-# 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.Conduit
import Control.Monad.IO.Class
import Data.Maybe
import Control.Monad
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
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
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as Map
import qualified Data.Aeson.Key as Key
#else
import qualified Data.HashMap.Lazy as Map
#endif
import Control.Applicative ((<$>), (<*>))
import Control.Exception (throwIO)

-- | Information received from Rpxnow after a valid login.
data Identifier = Identifier
    { Identifier -> Text
identifier :: Text
    , Identifier -> [(Text, Text)]
extraData :: [(Text, Text)]
    }
    deriving (Identifier -> Identifier -> Bool
(Identifier -> Identifier -> Bool)
-> (Identifier -> Identifier -> Bool) -> Eq Identifier
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Identifier -> Identifier -> Bool
$c/= :: Identifier -> Identifier -> Bool
== :: Identifier -> Identifier -> Bool
$c== :: Identifier -> Identifier -> Bool
Eq, Eq Identifier
Eq Identifier
-> (Identifier -> Identifier -> Ordering)
-> (Identifier -> Identifier -> Bool)
-> (Identifier -> Identifier -> Bool)
-> (Identifier -> Identifier -> Bool)
-> (Identifier -> Identifier -> Bool)
-> (Identifier -> Identifier -> Identifier)
-> (Identifier -> Identifier -> Identifier)
-> Ord Identifier
Identifier -> Identifier -> Bool
Identifier -> Identifier -> Ordering
Identifier -> Identifier -> Identifier
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Identifier -> Identifier -> Identifier
$cmin :: Identifier -> Identifier -> Identifier
max :: Identifier -> Identifier -> Identifier
$cmax :: Identifier -> Identifier -> Identifier
>= :: Identifier -> Identifier -> Bool
$c>= :: Identifier -> Identifier -> Bool
> :: Identifier -> Identifier -> Bool
$c> :: Identifier -> Identifier -> Bool
<= :: Identifier -> Identifier -> Bool
$c<= :: Identifier -> Identifier -> Bool
< :: Identifier -> Identifier -> Bool
$c< :: Identifier -> Identifier -> Bool
compare :: Identifier -> Identifier -> Ordering
$ccompare :: Identifier -> Identifier -> Ordering
$cp1Ord :: Eq Identifier
Ord, ReadPrec [Identifier]
ReadPrec Identifier
Int -> ReadS Identifier
ReadS [Identifier]
(Int -> ReadS Identifier)
-> ReadS [Identifier]
-> ReadPrec Identifier
-> ReadPrec [Identifier]
-> Read Identifier
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Identifier]
$creadListPrec :: ReadPrec [Identifier]
readPrec :: ReadPrec Identifier
$creadPrec :: ReadPrec Identifier
readList :: ReadS [Identifier]
$creadList :: ReadS [Identifier]
readsPrec :: Int -> ReadS Identifier
$creadsPrec :: Int -> ReadS Identifier
Read, Int -> Identifier -> ShowS
[Identifier] -> ShowS
Identifier -> String
(Int -> Identifier -> ShowS)
-> (Identifier -> String)
-> ([Identifier] -> ShowS)
-> Show Identifier
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Identifier] -> ShowS
$cshowList :: [Identifier] -> ShowS
show :: Identifier -> String
$cshow :: Identifier -> String
showsPrec :: Int -> Identifier -> ShowS
$cshowsPrec :: Int -> Identifier -> ShowS
Show, Typeable Identifier
DataType
Constr
Typeable Identifier
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> Identifier -> c Identifier)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c Identifier)
-> (Identifier -> Constr)
-> (Identifier -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c Identifier))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c Identifier))
-> ((forall b. Data b => b -> b) -> Identifier -> Identifier)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> Identifier -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> Identifier -> r)
-> (forall u. (forall d. Data d => d -> u) -> Identifier -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> Identifier -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Identifier -> m Identifier)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Identifier -> m Identifier)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Identifier -> m Identifier)
-> Data Identifier
Identifier -> DataType
Identifier -> Constr
(forall b. Data b => b -> b) -> Identifier -> Identifier
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Identifier -> c Identifier
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Identifier
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Identifier -> u
forall u. (forall d. Data d => d -> u) -> Identifier -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Identifier -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Identifier -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Identifier -> m Identifier
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Identifier -> m Identifier
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Identifier
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Identifier -> c Identifier
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Identifier)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Identifier)
$cIdentifier :: Constr
$tIdentifier :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> Identifier -> m Identifier
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Identifier -> m Identifier
gmapMp :: (forall d. Data d => d -> m d) -> Identifier -> m Identifier
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Identifier -> m Identifier
gmapM :: (forall d. Data d => d -> m d) -> Identifier -> m Identifier
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Identifier -> m Identifier
gmapQi :: Int -> (forall d. Data d => d -> u) -> Identifier -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Identifier -> u
gmapQ :: (forall d. Data d => d -> u) -> Identifier -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Identifier -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Identifier -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Identifier -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Identifier -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Identifier -> r
gmapT :: (forall b. Data b => b -> b) -> Identifier -> Identifier
$cgmapT :: (forall b. Data b => b -> b) -> Identifier -> Identifier
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Identifier)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Identifier)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c Identifier)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Identifier)
dataTypeOf :: Identifier -> DataType
$cdataTypeOf :: Identifier -> DataType
toConstr :: Identifier -> Constr
$ctoConstr :: Identifier -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Identifier
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Identifier
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Identifier -> c Identifier
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Identifier -> c Identifier
$cp1Data :: Typeable Identifier
Data, Typeable)

-- | Attempt to log a user in.
authenticate :: MonadIO m
             => String -- ^ API key given by RPXNOW.
             -> String -- ^ Token passed by client.
             -> Manager
             -> m Identifier
authenticate :: String -> String -> Manager -> m Identifier
authenticate String
apiKey String
token Manager
manager = do
    let body :: ByteString
body = [ByteString] -> ByteString
L.fromChunks
            [ ByteString
"apiKey="
            , String -> ByteString
S.pack String
apiKey
            , ByteString
"&token="
            , String -> ByteString
S.pack String
token
            ]
    Request
req' <- IO Request -> m Request
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://rpxnow.com"
    let req :: Request
req =
            Request
req'
                { method :: ByteString
method = ByteString
"POST"
                , path :: ByteString
path = ByteString
"api/v2/auth_info"
                , requestHeaders :: RequestHeaders
requestHeaders =
                    [ (HeaderName
"Content-Type", ByteString
"application/x-www-form-urlencoded")
                    ]
                , requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyLBS ByteString
body
                }
    Response ByteString
res <- Request -> Manager -> m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> Manager -> m (Response ByteString)
httpLbs Request
req Manager
manager
    let b :: ByteString
b = Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
res
    Value
o <- Result Value -> m Value
forall (m :: * -> *) a. MonadIO m => Result a -> m a
unResult (Result Value -> m Value) -> Result Value -> m Value
forall a b. (a -> b) -> a -> b
$ Parser Value -> ByteString -> Result Value
forall a. Parser a -> ByteString -> Result a
parse Parser Value
json ByteString
b
    --m <- fromMapping o
    let mstat :: Result String
mstat = ((Value -> Parser String) -> Value -> Result String)
-> Value -> (Value -> Parser String) -> Result String
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Value -> Parser String) -> Value -> Result String
forall a b. (a -> Parser b) -> a -> Result b
Data.Aeson.Types.parse Value
o ((Value -> Parser String) -> Result String)
-> (Value -> Parser String) -> Result String
forall a b. (a -> b) -> a -> b
$ \Value
v ->
                case Value
v of
                    Object Object
m -> Object
m Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"stat"
                    Value
_ -> Parser String
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    case Result String
mstat of
        Success String
"ok" -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Success String
stat -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ AuthenticateException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (AuthenticateException -> IO ()) -> AuthenticateException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> AuthenticateException
RpxnowException (String -> AuthenticateException)
-> String -> AuthenticateException
forall a b. (a -> b) -> a -> b
$
            String
"Rpxnow login not accepted: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
stat String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
L.unpack ByteString
b
        Result String
_ -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ AuthenticateException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (AuthenticateException -> IO ()) -> AuthenticateException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> AuthenticateException
RpxnowException String
"Now stat value found on Rpxnow response"
    case (Value -> Parser Identifier) -> Value -> Result Identifier
forall a b. (a -> Parser b) -> a -> Result b
Data.Aeson.Types.parse Value -> Parser Identifier
parseProfile Value
o of
        Success Identifier
x -> Identifier -> m Identifier
forall (m :: * -> *) a. Monad m => a -> m a
return Identifier
x
        Error String
e -> IO Identifier -> m Identifier
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Identifier -> m Identifier) -> IO Identifier -> m Identifier
forall a b. (a -> b) -> a -> b
$ AuthenticateException -> IO Identifier
forall e a. Exception e => e -> IO a
throwIO (AuthenticateException -> IO Identifier)
-> AuthenticateException -> IO Identifier
forall a b. (a -> b) -> a -> b
$ String -> AuthenticateException
RpxnowException (String -> AuthenticateException)
-> String -> AuthenticateException
forall a b. (a -> b) -> a -> b
$ String
"Unable to parse Rpxnow response: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e

unResult :: MonadIO m => AT.Result a -> m a
unResult :: Result a -> m a
unResult = (String -> m a) -> (a -> m a) -> Either String a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (String -> IO a) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthenticateException -> IO a
forall e a. Exception e => e -> IO a
throwIO (AuthenticateException -> IO a)
-> (String -> AuthenticateException) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AuthenticateException
RpxnowException) a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a -> m a)
-> (Result a -> Either String a) -> Result a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result a -> Either String a
forall r. Result r -> Either String r
AT.eitherResult

parseProfile :: Value -> Data.Aeson.Types.Parser Identifier
parseProfile :: Value -> Parser Identifier
parseProfile (Object Object
m) = do
    Object
profile <- Object
m Object -> Key -> Parser Object
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"profile"
    Text -> [(Text, Text)] -> Identifier
Identifier
        (Text -> [(Text, Text)] -> Identifier)
-> Parser Text -> Parser ([(Text, Text)] -> Identifier)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
profile Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"identifier")
        Parser ([(Text, Text)] -> Identifier)
-> Parser [(Text, Text)] -> Parser Identifier
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(Text, Text)] -> Parser [(Text, Text)]
forall (m :: * -> *) a. Monad m => a -> m a
return (((Key, Value) -> Maybe (Text, Text))
-> [(Key, Value)] -> [(Text, Text)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Key, Value) -> Maybe (Text, Text)
go (Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
Map.toList Object
profile))
  where
    go :: (Key, Value) -> Maybe (Text, Text)
go (Key
"identifier", Value
_) = Maybe (Text, Text)
forall a. Maybe a
Nothing
    go (Key
k, String Text
v) = (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (
#if MIN_VERSION_aeson(2,0,0)
        Key -> Text
Key.toText
#endif
        Key
k, Text
v)
    go (Key, Value)
_ = Maybe (Text, Text)
forall a. Maybe a
Nothing
parseProfile Value
_ = Parser Identifier
forall (m :: * -> *) a. MonadPlus m => m a
mzero