authenticate 0.0.1 → 0.2.0

raw patch · 3 files changed

+65/−62 lines, 3 filesdep +attemptdep +sybdep +transformersdep ~basedep ~http-wgetPVP ok

version bump matches the API change (PVP)

Dependencies added: attempt, syb, transformers

Dependency ranges changed: base, http-wget

API changes (from Hackage documentation)

Files

• Web/Authenticate/OpenId.hs +41/−44
• Web/Authenticate/Rpxnow.hs +15/−15
• authenticate.cabal +9/−3

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-} --------------------------------------------------------- -- | -- Module        : Web.Authenticate.OpenId@@ -18,13 +19,18 @@     , authenticate     ) where -import Data.Maybe (fromMaybe, fromJust) import Network.HTTP.Wget import Text.HTML.TagSoup import Numeric (showHex)+import Control.Monad.Trans+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 }+newtype Identifier = Identifier { identifier :: String }+    deriving (Eq, Show)  data Error v = Error String | Ok v instance Monad Error where@@ -34,24 +40,22 @@     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 (~== ("<link rel=openid." ++ var ++ ">")) tags@@ -73,36 +77,29 @@  -- | 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)+-- Otherwise, 'failure's an explanation.+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 @@                 ]             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

@@ -16,9 +16,11 @@     , 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 @@     }  -- | 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

@@ -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>@@ -8,13 +8,19 @@ description:     Focus is on remote authentication methods, such as OpenID,                  rpxnow and Google. category:        Web-stability:       unstable+stability:       Stable cabal-version:   >= 1.2 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