Switch to MonadAttempt for error handling

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 [] []
+    bodyIdent <- wget openid [] []
-    case bodyIdent' of
+    server <- getOpenIdVar "server" bodyIdent
-        Error s -> return $ fail s
+    let delegate = attempt (const openid) id
-        Ok bodyIdent -> do
+                 $ getOpenIdVar "delegate" bodyIdent
-        server <- getOpenIdVar "server" bodyIdent
+    return $ constructUrl server
-        let delegate = fromMaybe openid $ getOpenIdVar "delegate" bodyIdent
+                        [ ("openid.mode", "checkid_setup")
-        return $ return $ constructUrl server
+                        , ("openid.identity", delegate)
-                            [ ("openid.mode", "checkid_setup")
+                        , ("openid.return_to", complete)
-                            , ("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 (~== ("<link rel=openid." ++ var ++ ">")) 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
+    authUrl <- getAuthUrl req
-    case authUrl' of
+    content <- wget authUrl [] []
-        Nothing -> return $ fail "Invalid parameters"
+    let isValid = contains "is_valid:true" content
-        Just authUrl -> do
+    if isValid
-            content' <- wget authUrl [] []
+        then A.lookup "openid.identity" req >>= return . Identifier
-            case content' of
+        else failure $ AuthenticateError content
-                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
 
-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
+    identity <- A.lookup "openid.identity" req
-    case identity' of
+    idContent <- wget identity [] []
-        Nothing -> return Nothing
+    helper idContent
-        Just identity -> do
-            idContent <- wget identity [] []
-            case idContent of
-                Nothing -> return Nothing
-                Just x -> return $ helper x
     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

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
+  case decode b >>= getObject of
-        Left s -> return $ fail $ "Unable to connect to rpxnow: " ++ s
+    Error s -> failureString $ "Not a valid JSON response: " ++ s
-        Right b ->
+    Ok o ->
-          case decode b >>= getObject of
+      case valFromObj "stat" o of
-            Error s -> return $ fail $ "Not a valid JSON response: " ++ s
+        Error _ -> failureString "Missing 'stat' field"
-            Ok o ->
+        Ok "ok" -> parseProfile o
-              case valFromObj "stat" o of
+        Ok stat -> failureString $ "Login not accepted: " ++ stat
-                Error _ -> return $ fail "Missing 'stat' field"
+                   ++ "\n" ++ b
-                Ok "ok" -> return $ parseProfile o
-                Ok stat -> return $ fail $ "Login not accepted: " ++ stat
 
-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

authenticate.cabal

@@ -1,5 +1,5 @@
 name:            authenticate
-version:         0.0.1
+version:         0.2.0
 license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -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