diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs
index e1141032..a99acc2f 100644
--- a/Web/Authenticate/OpenId.hs
+++ b/Web/Authenticate/OpenId.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveDataTypeable #-}
---------------------------------------------------------
-- |
-- Module : Web.Authenticate.OpenId
@@ -18,10 +19,15 @@ module Web.Authenticate.OpenId
, authenticate
) where
-import Data.Maybe (fromMaybe, fromJust)
import Network.HTTP.Wget
import Text.HTML.TagSoup
import Numeric (showHex)
+import Control.Monad.Trans
+import Control.Monad.Attempt.Class
+import qualified Data.Attempt.Helper as A
+import Data.Generics
+import Data.Attempt
+import Control.Exception
-- | An openid identifier (ie, a URL).
data Identifier = Identifier { identifier :: String }
@@ -34,24 +40,22 @@ instance Monad Error where
fail s = Error s
-- | Returns a URL to forward the user to in order to login.
-getForwardUrl :: Monad m
+getForwardUrl :: (MonadIO m, MonadAttempt m)
=> String -- ^ The openid the user provided.
-> String -- ^ The URL for this application\'s complete page.
- -> IO (m String) -- ^ URL to send the user to.
+ -> m String -- ^ URL to send the user to.
getForwardUrl openid complete = do
- bodyIdent' <- wget openid [] []
- case bodyIdent' of
- Error s -> return $ fail s
- Ok bodyIdent -> do
- server <- getOpenIdVar "server" bodyIdent
- let delegate = fromMaybe openid $ getOpenIdVar "delegate" bodyIdent
- return $ return $ constructUrl server
- [ ("openid.mode", "checkid_setup")
- , ("openid.identity", delegate)
- , ("openid.return_to", complete)
- ]
+ bodyIdent <- wget openid [] []
+ server <- getOpenIdVar "server" bodyIdent
+ let delegate = attempt (const openid) id
+ $ getOpenIdVar "delegate" bodyIdent
+ return $ constructUrl server
+ [ ("openid.mode", "checkid_setup")
+ , ("openid.identity", delegate)
+ , ("openid.return_to", complete)
+ ]
-getOpenIdVar :: Monad m => String -> String -> m String
+getOpenIdVar :: MonadAttempt m => String -> String -> m String
getOpenIdVar var content = do
let tags = parseTags content
let secs = sections (~== ("")) tags
@@ -74,35 +78,28 @@ constructUrl url args = url ++ "?" ++ queryString args
-- | Handle a redirect from an OpenID provider and check that the user
-- logged in properly. If it was successfully, 'return's the openid.
-- Otherwise, 'fail's an explanation.
-authenticate :: Monad m => [(String, String)] -> IO (m Identifier)
+authenticate :: (MonadIO m, MonadAttempt m)
+ => [(String, String)]
+ -> m Identifier
authenticate req = do -- FIXME check openid.mode == id_res (not cancel)
- authUrl' <- getAuthUrl req
- case authUrl' of
- Nothing -> return $ fail "Invalid parameters"
- Just authUrl -> do
- content' <- wget authUrl [] []
- case content' of
- Error s -> return $ fail s
- Ok content -> do
- let isValid = contains "is_valid:true" content
- if isValid
- then return $
- return $ Identifier
- (fromJust $ lookup "openid.identity" req)
- else return $ fail content
+ authUrl <- getAuthUrl req
+ content <- wget authUrl [] []
+ let isValid = contains "is_valid:true" content
+ if isValid
+ then A.lookup "openid.identity" req >>= return . Identifier
+ else failure $ AuthenticateError content
-getAuthUrl :: [(String, String)] -> IO (Maybe String)
+newtype AuthenticateError = AuthenticateError String
+ deriving (Show, Typeable)
+instance Exception AuthenticateError
+
+getAuthUrl :: (MonadIO m, MonadAttempt m) => [(String, String)] -> m String
getAuthUrl req = do
- let identity' = lookup "openid.identity" req
- case identity' of
- Nothing -> return Nothing
- Just identity -> do
- idContent <- wget identity [] []
- case idContent of
- Nothing -> return Nothing
- Just x -> return $ helper x
+ identity <- A.lookup "openid.identity" req
+ idContent <- wget identity [] []
+ helper idContent
where
- helper :: String -> Maybe String
+ helper :: MonadAttempt m => String -> m String
helper idContent = do
server <- getOpenIdVar "server" idContent
dargs <- mapM makeArg [
@@ -114,10 +111,10 @@ getAuthUrl req = do
]
let sargs = [("openid.mode", "check_authentication")]
return $ constructUrl server $ dargs ++ sargs
- makeArg :: String -> Maybe (String, String)
+ makeArg :: MonadAttempt m => String -> m (String, String)
makeArg s = do
let k = "openid." ++ s
- v <- lookup k req
+ v <- A.lookup k req
return (k, v)
contains :: String -> String -> Bool
diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs
index d7f8d279..c6449d9d 100644
--- a/Web/Authenticate/Rpxnow.hs
+++ b/Web/Authenticate/Rpxnow.hs
@@ -16,9 +16,11 @@ module Web.Authenticate.Rpxnow
, authenticate
) where
-import Text.JSON
+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
@@ -27,29 +29,27 @@ data Identifier = Identifier
}
-- | Attempt to log a user in.
-authenticate :: Monad m
+authenticate :: (MonadIO m, MonadAttempt m)
=> String -- ^ API key given by RPXNOW.
-> String -- ^ Token passed by client.
- -> IO (m Identifier)
+ -> m Identifier
authenticate apiKey token = do
- body <- wget
+ b <- wget
"https://rpxnow.com/api/v2/auth_info"
[]
[ ("apiKey", apiKey)
, ("token", token)
]
- case body of
- Left s -> return $ fail $ "Unable to connect to rpxnow: " ++ s
- Right b ->
- case decode b >>= getObject of
- Error s -> return $ fail $ "Not a valid JSON response: " ++ s
- Ok o ->
- case valFromObj "stat" o of
- Error _ -> return $ fail "Missing 'stat' field"
- Ok "ok" -> return $ parseProfile o
- Ok stat -> return $ fail $ "Login not accepted: " ++ stat
+ 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 :: Monad m => JSObject JSValue -> m Identifier
+parseProfile :: MonadAttempt m => JSObject JSValue -> m Identifier
parseProfile v = do
profile <- resultToMonad $ valFromObj "profile" v >>= getObject
ident <- resultToMonad $ valFromObj "identifier" profile
diff --git a/authenticate.cabal b/authenticate.cabal
index 6b7a2576..dfffc280 100644
--- a/authenticate.cabal
+++ b/authenticate.cabal
@@ -1,5 +1,5 @@
name: authenticate
-version: 0.0.1
+version: 0.2.0
license: BSD3
license-file: LICENSE
author: Michael Snoyman
@@ -14,7 +14,13 @@ build-type: Simple
homepage: http://github.com/snoyberg/authenticate/tree/master
library
- build-depends: base, json, http-wget, tagsoup
+ build-depends: base >= 4 && < 5,
+ json,
+ http-wget >= 0.2.0,
+ tagsoup,
+ attempt,
+ transformers >= 0.1.4.0,
+ syb
exposed-modules: Web.Authenticate.Rpxnow,
Web.Authenticate.OpenId
ghc-options: -Wall -fno-warn-orphans