module Web.Authenticate.Rpxnow
( Identifier (..)
, authenticate
) where
import Text.JSON
import Network.HTTP.Wget
import Data.Maybe (isJust, fromJust)
import Control.Monad.Trans
import Control.Monad.Attempt.Class
data Identifier = Identifier
{ identifier :: String
, extraData :: [(String, String)]
}
authenticate :: (MonadIO m, MonadAttempt m)
=> String
-> String
-> 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