authenticate 0.2.0 → 0.2.1
raw patch · 3 files changed
+29/−20 lines, 3 filesdep +control-monad-failuredep +safe-failuredep −attemptdep ~http-wget
Dependencies added: control-monad-failure, safe-failure
Dependencies removed: attempt
Dependency ranges changed: http-wget
Files
- Web/Authenticate/OpenId.hs +20/−13
- Web/Authenticate/Rpxnow.hs +5/−4
- authenticate.cabal +4/−3
Web/Authenticate/OpenId.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-} --------------------------------------------------------- -- | -- Module : Web.Authenticate.OpenId@@ -23,9 +24,9 @@ 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 @@ 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 @@ , ("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 (~== ("<link rel=openid." ++ var ++ ">")) tags@@ -63,7 +64,7 @@ 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 @@ -- | 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 @@ 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 @@ ] 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
Web/Authenticate/Rpxnow.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} --------------------------------------------------------- -- -- Module : Web.Authenticate.Rpxnow@@ -20,7 +21,7 @@ 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 @@ } -- | 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 @@ , ("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 @@ 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
authenticate.cabal view
@@ -1,5 +1,5 @@ name: authenticate-version: 0.2.0+version: 0.2.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -16,9 +16,10 @@ 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,