diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs index 980cfa0d..01c49b87 100644 --- a/Web/Restful/Handler.hs +++ b/Web/Restful/Handler.hs @@ -36,6 +36,7 @@ import Web.Restful.Request import Web.Restful.Response import Control.Monad.Trans +import Control.Monad.Attempt.Class import Control.Monad (liftM, ap) import Control.Applicative @@ -131,6 +132,9 @@ instance Monad m => MonadRequestReader (HandlerT m) where errorResult $ InvalidArgs [(name ++ " (" ++ show ptype ++ ")", msg)] authRequired = errorResult PermissionDenied +instance Monad m => MonadAttempt (HandlerT m) where + failure = errorResult . InternalError . show + ------ Special handlers errorResult :: Monad m => ErrorResult -> HandlerT m a errorResult er = HandlerT (const $ return (Left er, [])) diff --git a/Web/Restful/Helpers/Auth.hs b/Web/Restful/Helpers/Auth.hs index 9b3457ec..6e3207de 100644 --- a/Web/Restful/Helpers/Auth.hs +++ b/Web/Restful/Helpers/Auth.hs @@ -31,8 +31,10 @@ import Web.Restful.Constants import Control.Applicative ((<$>), Applicative (..)) import Control.Monad.Reader +import Control.Monad.Attempt import Data.Maybe (fromMaybe) +import Data.Attempt data AuthResource = Check @@ -104,21 +106,21 @@ authOpenidForward = do let complete = "http://" ++ Hack.serverName env ++ ":" ++ show (Hack.serverPort env) ++ "/auth/openid/complete/" - res <- liftIO $ OpenId.getForwardUrl oid complete + res <- runAttemptT $ OpenId.getForwardUrl oid complete case res of - Left err -> redirect $ "/auth/openid/?message=" - ++ encodeUrl (err :: String) - Right url -> redirect url + Failure err -> redirect $ "/auth/openid/?message=" + ++ encodeUrl (show err) + Success url -> redirect url authOpenidComplete :: Handler authOpenidComplete = do gets' <- rawGetParams <$> askRawRequest dest <- cookieParam "DEST" - res <- liftIO $ OpenId.authenticate gets' + res <- runAttemptT $ OpenId.authenticate gets' case res of - Left err -> redirect $ "/auth/openid/?message=" - ++ encodeUrl (err :: String) - Right (OpenId.Identifier ident) -> do + Failure err -> redirect $ "/auth/openid/?message=" + ++ encodeUrl (show err) + Success (OpenId.Identifier ident) -> do deleteCookie "DEST" header authCookieName ident redirect $ fromMaybe "/" dest @@ -148,7 +150,7 @@ rpxnowLogin apiKey = do Just "" -> "/" Just ('#':rest) -> rest Just s -> s - ident <- join $ liftIO $ Rpxnow.authenticate apiKey token + ident <- Rpxnow.authenticate apiKey token header authCookieName $ Rpxnow.identifier ident redirect dest diff --git a/Web/Restful/Request.hs b/Web/Restful/Request.hs index 46446b89..c2e93460 100644 --- a/Web/Restful/Request.hs +++ b/Web/Restful/Request.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE OverlappingInstances #-} --------------------------------------------------------- -- @@ -50,7 +49,6 @@ module Web.Restful.Request import qualified Hack import Data.Function.Predicate (equals) -import Control.Monad.Error () import Web.Restful.Constants import Web.Restful.Utils import Control.Applicative (Applicative (..)) @@ -275,9 +273,17 @@ instance Parameter a => Parameter (Maybe a) where " values, expecting 0 or 1" instance Parameter a => Parameter [a] where - readParams = mapM readParam + readParams = mapM' readParam where + mapM' f = sequence' . map f + sequence' :: [Either String v] -> Either String [v] + sequence' [] = Right [] + sequence' (Left l:_) = Left l + sequence' (Right r:rest) = + case sequence' rest of + Left l -> Left l + Right rest' -> Right $ r : rest' -instance Parameter String where +instance Parameter [Char] where readParam = Right . paramValue instance Parameter Int where diff --git a/restful.cabal b/restful.cabal index 0d989903..32c3084b 100644 --- a/restful.cabal +++ b/restful.cabal @@ -1,5 +1,5 @@ name: restful -version: 0.1.8 +version: 0.1.9 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -22,13 +22,12 @@ library hack-handler-cgi >= 0.0.2, hack >= 2009.5.19, split >= 0.1.1, - authenticate >= 0.0.1, + authenticate >= 0.2.0, data-default >= 0.2, predicates >= 0.1, bytestring >= 0.9.1.4, bytestring-class, web-encodings >= 0.0.1, - mtl >= 1.1.0.2, data-object >= 0.2.0, yaml >= 0.2.0, test-framework, @@ -37,7 +36,10 @@ library HUnit, QuickCheck == 1.*, enumerable >= 0.0.3, - directory >= 1 + directory >= 1, + transformers >= 0.1.4.0, + monads-fd >= 0.0.0.1, + attempt exposed-modules: Web.Restful, Web.Restful.Constants, Web.Restful.Request,