{-# 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
#if MIN_VERSION_aeson(2,2,0)
import Data.Aeson.Parser (json)
#endif
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
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
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
Ord, ReadPrec [Identifier]
ReadPrec Identifier
Int -> ReadS Identifier
ReadS [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
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
Identifier -> DataType
Identifier -> Constr
(forall b. Data b => b -> b) -> Identifier -> 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)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(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 (m :: * -> *).
MonadPlus m =>
(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 (m :: * -> *).
Monad m =>
(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 :: forall u. Int -> (forall d. Data d => d -> u) -> Identifier -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Identifier -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> Identifier -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Identifier -> [u]
gmapQr :: forall r r'.
(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 :: forall r r'.
(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 (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(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 (t :: * -> *) (c :: * -> *).
Typeable t =>
(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 (c :: * -> *).
(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 (c :: * -> *).
(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
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 :: forall (m :: * -> *).
MonadIO m =>
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' <- 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://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 <- forall (m :: * -> *).
MonadIO m =>
Request -> Manager -> m (Response ByteString)
httpLbs Request
req Manager
manager
    let b :: ByteString
b = forall body. Response body -> body
responseBody Response ByteString
res
    Value
o <- forall (m :: * -> *) a. MonadIO m => Result a -> m a
unResult forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> ByteString -> Result a
parse Parser Value
json ByteString
b
    --m <- fromMapping o
    let mstat :: Result String
mstat = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> Parser b) -> a -> Result b
Data.Aeson.Types.parse Value
o forall a b. (a -> b) -> a -> b
$ \Value
v ->
                case Value
v of
                    Object Object
m -> Object
m forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"stat"
                    Value
_ -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
    case Result String
mstat of
        Success String
"ok" -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Success String
stat -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> AuthenticateException
RpxnowException forall a b. (a -> b) -> a -> b
$
            String
"Rpxnow login not accepted: " forall a. [a] -> [a] -> [a]
++ String
stat forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ ByteString -> String
L.unpack ByteString
b
        Result String
_ -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> AuthenticateException
RpxnowException String
"Now stat value found on Rpxnow response"
    case forall a b. (a -> Parser b) -> a -> Result b
Data.Aeson.Types.parse Value -> Parser Identifier
parseProfile Value
o of
        Success Identifier
x -> forall (m :: * -> *) a. Monad m => a -> m a
return Identifier
x
        Error String
e -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> AuthenticateException
RpxnowException forall a b. (a -> b) -> a -> b
$ String
"Unable to parse Rpxnow response: " forall a. [a] -> [a] -> [a]
++ String
e

unResult :: MonadIO m => AT.Result a -> m a
unResult :: forall (m :: * -> *) a. MonadIO m => Result a -> m a
unResult = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => e -> IO a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AuthenticateException
RpxnowException) forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"profile"
    Text -> [(Text, Text)] -> Identifier
Identifier
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
profile forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"identifier")
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Key, Value) -> Maybe (Text, Text)
go (forall v. KeyMap v -> [(Key, v)]
Map.toList Object
profile))
  where
    go :: (Key, Value) -> Maybe (Text, Text)
go (Key
"identifier", Value
_) = forall a. Maybe a
Nothing
    go (Key
k, String Text
v) = 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)
_ = forall a. Maybe a
Nothing
parseProfile Value
_ = forall (m :: * -> *) a. MonadPlus m => m a
mzero