From 83d2d25d34b3ac1774ed66e08783a605456798f9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 13 Nov 2009 15:13:36 +0200 Subject: [PATCH] Migration to control-monad-failure --- Web/Authenticate/OpenId.hs | 33 ++++++++++++++++++++------------- Web/Authenticate/Rpxnow.hs | 9 +++++---- authenticate.cabal | 7 ++++--- 3 files changed, 29 insertions(+), 20 deletions(-) diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index d2e87e3d..754b4751 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} --------------------------------------------------------- -- | -- Module : Web.Authenticate.OpenId @@ -23,9 +24,9 @@ import Network.HTTP.Wget import Text.HTML.TagSoup import Numeric (showHex) import Control.Monad.Trans -import qualified Data.Attempt.Helper as A +import qualified Safe.Failure as A import Data.Generics -import Data.Attempt +import Control.Monad.Failure import Control.Exception -- | An openid identifier (ie, a URL). @@ -40,14 +41,14 @@ instance Monad Error where fail s = Error s -- | Returns a URL to forward the user to in order to login. -getForwardUrl :: (MonadIO m, MonadAttempt m) +getForwardUrl :: (MonadIO m, MonadFailure WgetException m) => String -- ^ The openid the user provided. -> String -- ^ The URL for this application\'s complete page. -> m String -- ^ URL to send the user to. getForwardUrl openid complete = do bodyIdent <- wget openid [] [] server <- getOpenIdVar "server" bodyIdent - let delegate = attempt (const openid) id + let delegate = maybe openid id $ getOpenIdVar "delegate" bodyIdent return $ constructUrl server [ ("openid.mode", "checkid_setup") @@ -55,7 +56,7 @@ getForwardUrl openid complete = do , ("openid.return_to", complete) ] -getOpenIdVar :: MonadAttempt m => String -> String -> m String +getOpenIdVar :: Monad m => String -> String -> m String getOpenIdVar var content = do let tags = parseTags content let secs = sections (~== ("")) tags @@ -63,7 +64,7 @@ getOpenIdVar var content = do secs'' <- mhead secs' return $ fromAttrib "href" secs'' where - mhead [] = fail $ "Variable not found: openid." ++ var + mhead [] = fail $ "Variable not found: openid." ++ var -- FIXME mhead (x:_) = return x constructUrl :: String -> [(String, String)] -> String @@ -78,7 +79,9 @@ 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, 'failure's an explanation. -authenticate :: (MonadIO m, MonadAttempt m) +authenticate :: (MonadIO m, MonadFailure WgetException m, + MonadFailure (A.LookupFailure String) m, + MonadFailure AuthenticateException m) => [(String, String)] -> m Identifier authenticate req = do -- FIXME check openid.mode == id_res (not cancel) @@ -87,19 +90,22 @@ authenticate req = do -- FIXME check openid.mode == id_res (not cancel) let isValid = contains "is_valid:true" content if isValid then A.lookup "openid.identity" req >>= return . Identifier - else failure $ AuthenticateError content + else failure $ AuthenticateException content -newtype AuthenticateError = AuthenticateError String +newtype AuthenticateException = AuthenticateException String deriving (Show, Typeable) -instance Exception AuthenticateError +instance Exception AuthenticateException -getAuthUrl :: (MonadIO m, MonadAttempt m) => [(String, String)] -> m String +getAuthUrl :: (MonadIO m, MonadFailure (A.LookupFailure String) m, + MonadFailure WgetException m) + => [(String, String)] -> m String getAuthUrl req = do identity <- A.lookup "openid.identity" req idContent <- wget identity [] [] helper idContent where - helper :: MonadAttempt m => String -> m String + helper :: MonadFailure (A.LookupFailure String) m + => String -> m String helper idContent = do server <- getOpenIdVar "server" idContent dargs <- mapM makeArg [ @@ -111,7 +117,8 @@ getAuthUrl req = do ] let sargs = [("openid.mode", "check_authentication")] return $ constructUrl server $ dargs ++ sargs - makeArg :: MonadAttempt m => String -> m (String, String) + makeArg :: MonadFailure (A.LookupFailure String) m + => String -> m (String, String) makeArg s = do let k = "openid." ++ s v <- A.lookup k req diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs index c6449d9d..337ec927 100644 --- a/Web/Authenticate/Rpxnow.hs +++ b/Web/Authenticate/Rpxnow.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} --------------------------------------------------------- -- -- Module : Web.Authenticate.Rpxnow @@ -20,7 +21,7 @@ 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 +import Control.Monad.Failure -- | Information received from Rpxnow after a valid login. data Identifier = Identifier @@ -29,7 +30,7 @@ data Identifier = Identifier } -- | Attempt to log a user in. -authenticate :: (MonadIO m, MonadAttempt m) +authenticate :: (MonadIO m, MonadFailure WgetException m, MonadFailure StringException m) => String -- ^ API key given by RPXNOW. -> String -- ^ Token passed by client. -> m Identifier @@ -41,7 +42,7 @@ authenticate apiKey token = do , ("token", token) ] case decode b >>= getObject of - Error s -> failureString $ "Not a valid JSON response: " ++ s + Error s -> failureString $ "Not a valid JSON response: " ++ s -- FIXME Ok o -> case valFromObj "stat" o of Error _ -> failureString "Missing 'stat' field" @@ -49,7 +50,7 @@ authenticate apiKey token = do Ok stat -> failureString $ "Login not accepted: " ++ stat ++ "\n" ++ b -parseProfile :: MonadAttempt m => JSObject JSValue -> m Identifier +parseProfile :: Monad 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 b50a2c8c..48f90f1f 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.2.0 +version: 0.2.1 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -16,9 +16,10 @@ homepage: http://github.com/snoyberg/authenticate/tree/master library build-depends: base >= 4 && < 5, json, - http-wget >= 0.2.0, + http-wget >= 0.2.1, tagsoup, - attempt, + control-monad-failure, + safe-failure, transformers >= 0.1.4.0, syb exposed-modules: Web.Authenticate.Rpxnow,