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