1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
|
{-# 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
import qualified Data.HashMap.Lazy as Map
import Control.Applicative ((<$>), (<*>))
import Control.Exception (throwIO)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Trans.Resource (MonadResource)
-- | 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 :: (MonadResource m, MonadBaseControl IO m)
=> String -- ^ API key given by RPXNOW.
-> String -- ^ Token passed by client.
-> Manager
-> m Identifier
authenticate apiKey token manager = do
let body = L.fromChunks
[ "apiKey="
, S.pack apiKey
, "&token="
, S.pack token
]
req' <- liftIO $ 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 <- httpLbs req manager
let b = responseBody res
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 -> liftIO $ throwIO $ RpxnowException $
"Rpxnow login not accepted: " ++ stat ++ "\n" ++ L.unpack b
_ -> liftIO $ throwIO $ RpxnowException "Now stat value found on Rpxnow response"
case Data.Aeson.Types.parse parseProfile o of
Success x -> return x
Error e -> liftIO $ throwIO $ RpxnowException $ "Unable to parse Rpxnow response: " ++ e
unResult :: MonadIO m => AT.Result a -> m a
unResult = either (liftIO . throwIO . 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
|
