72 lines
2.3 KiB
Haskell
72 lines
2.3 KiB
Haskell
---------------------------------------------------------
|
|
--
|
|
-- 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
|
|
) where
|
|
|
|
import Text.JSON -- FIXME use Data.Object.JSON
|
|
import Network.HTTP.Wget
|
|
import Data.Maybe (isJust, fromJust)
|
|
import Control.Monad.Trans
|
|
import Control.Monad.Attempt.Class
|
|
|
|
-- | Information received from Rpxnow after a valid login.
|
|
data Identifier = Identifier
|
|
{ identifier :: String
|
|
, extraData :: [(String, String)]
|
|
}
|
|
|
|
-- | Attempt to log a user in.
|
|
authenticate :: (MonadIO m, MonadAttempt m)
|
|
=> String -- ^ API key given by RPXNOW.
|
|
-> String -- ^ Token passed by client.
|
|
-> m Identifier
|
|
authenticate apiKey token = do
|
|
b <- wget
|
|
"https://rpxnow.com/api/v2/auth_info"
|
|
[]
|
|
[ ("apiKey", apiKey)
|
|
, ("token", token)
|
|
]
|
|
case decode b >>= getObject of
|
|
Error s -> failureString $ "Not a valid JSON response: " ++ s
|
|
Ok o ->
|
|
case valFromObj "stat" o of
|
|
Error _ -> failureString "Missing 'stat' field"
|
|
Ok "ok" -> parseProfile o
|
|
Ok stat -> failureString $ "Login not accepted: " ++ stat
|
|
++ "\n" ++ b
|
|
|
|
parseProfile :: MonadAttempt m => JSObject JSValue -> m Identifier
|
|
parseProfile v = do
|
|
profile <- resultToMonad $ valFromObj "profile" v >>= getObject
|
|
ident <- resultToMonad $ valFromObj "identifier" profile
|
|
let pairs = fromJSObject profile
|
|
pairs' = filter (\(k, _) -> k /= "identifier") pairs
|
|
pairs'' = map fromJust . filter isJust . map takeString $ pairs'
|
|
return $ Identifier ident pairs''
|
|
|
|
takeString :: (String, JSValue) -> Maybe (String, String)
|
|
takeString (k, JSString v) = Just (k, fromJSString v)
|
|
takeString _ = Nothing
|
|
|
|
getObject :: Monad m => JSValue -> m (JSObject JSValue)
|
|
getObject (JSObject o) = return o
|
|
getObject _ = fail "Not an object"
|
|
|
|
resultToMonad :: Monad m => Result a -> m a
|
|
resultToMonad (Ok x) = return x
|
|
resultToMonad (Error s) = fail s
|