diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE PackageImports #-} --------------------------------------------------------- -- | -- Module : Web.Authenticate.OpenId @@ -19,20 +20,21 @@ ( Identifier (..) , getForwardUrl , authenticate + , AuthenticateException (..) ) where import Network.HTTP.Wget import Text.HTML.TagSoup import Numeric (showHex) -import qualified Safe.Failure as A -#if TRANSFORMERS_02 -import Control.Monad.IO.Class +#if MIN_VERSION_transformers(0,2,0) +import "transformers" Control.Monad.IO.Class #else -import Control.Monad.Trans +import "transformers" Control.Monad.Trans #endif -import Data.Generics +import Data.Data import Control.Failure hiding (Error) import Control.Exception +import Control.Monad (liftM) -- | An openid identifier (ie, a URL). newtype Identifier = Identifier { identifier :: String } @@ -46,7 +48,7 @@ fail s = Error s -- | Returns a URL to forward the user to in order to login. -getForwardUrl :: (MonadIO m, MonadFailure WgetException m) +getForwardUrl :: (MonadIO m, Failure 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. @@ -84,9 +86,8 @@ -- | 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, MonadFailure WgetException m, - MonadFailure (A.LookupFailure String) m, - MonadFailure AuthenticateException m) +authenticate :: (MonadIO m, Failure WgetException m, + Failure AuthenticateException m) => [(String, String)] -> m Identifier authenticate req = do -- FIXME check openid.mode == id_res (not cancel) @@ -94,23 +95,31 @@ content <- wget authUrl [] [] let isValid = contains "is_valid:true" content if isValid - then A.lookup "openid.identity" req >>= return . Identifier + then Identifier `liftM` alookup "openid.identity" req else failure $ AuthenticateException content -newtype AuthenticateException = AuthenticateException String +alookup :: (Failure AuthenticateException m, Monad m) + => String + -> [(String, String)] + -> m String +alookup k x = case lookup k x of + Just k -> return k + Nothing -> failure $ MissingOpenIdParameter k + +data AuthenticateException = AuthenticateException String + | MissingOpenIdParameter String deriving (Show, Typeable) instance Exception AuthenticateException -getAuthUrl :: (MonadIO m, MonadFailure (A.LookupFailure String) m, - MonadFailure WgetException m) +getAuthUrl :: (MonadIO m, + Failure AuthenticateException m, + Failure WgetException m) => [(String, String)] -> m String getAuthUrl req = do - identity <- A.lookup "openid.identity" req + identity <- alookup "openid.identity" req idContent <- wget identity [] [] helper idContent where - helper :: MonadFailure (A.LookupFailure String) m - => String -> m String helper idContent = do server <- getOpenIdVar "server" idContent dargs <- mapM makeArg [ @@ -122,11 +131,9 @@ ] let sargs = [("openid.mode", "check_authentication")] return $ constructUrl server $ dargs ++ sargs - makeArg :: MonadFailure (A.LookupFailure String) m - => String -> m (String, String) makeArg s = do let k = "openid." ++ s - v <- A.lookup k req + v <- alookup k req return (k, v) contains :: String -> String -> Bool diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs --- a/Web/Authenticate/Rpxnow.hs +++ b/Web/Authenticate/Rpxnow.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE PackageImports #-} --------------------------------------------------------- -- -- Module : Web.Authenticate.Rpxnow @@ -18,15 +19,19 @@ , authenticate ) where -import Text.JSON -- FIXME use Data.Object.JSON +import Data.Object +import Data.Object.Json import Network.HTTP.Wget -import Data.Maybe (isJust, fromJust) -#if TRANSFORMERS_02 -import Control.Monad.IO.Class +#if MIN_VERSION_transformers(0,2,0) +import "transformers" Control.Monad.IO.Class #else -import Control.Monad.Trans +import "transformers" Control.Monad.Trans #endif import Control.Failure +import Data.Maybe +import Web.Authenticate.OpenId (AuthenticateException (..)) +import Control.Monad +import Data.ByteString.Char8 (pack) -- | Information received from Rpxnow after a valid login. data Identifier = Identifier @@ -35,43 +40,35 @@ } -- | Attempt to log a user in. -authenticate :: (MonadIO m, MonadFailure WgetException m, MonadFailure StringException m) +authenticate :: (MonadIO m, + Failure WgetException m, + Failure AuthenticateException m, + Failure ObjectExtractError m, + Failure JsonDecodeError m) => String -- ^ API key given by RPXNOW. -> String -- ^ Token passed by client. -> m Identifier authenticate apiKey token = do - b <- wget - "https://rpxnow.com/api/v2/auth_info" - [] - [ ("apiKey", apiKey) - , ("token", token) - ] - case decode b >>= getObject of - Error s -> failureString $ "Not a valid JSON response: " ++ s -- FIXME - 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 v = do - profile <- resultToMonad $ valFromObj "profile" v >>= getObject - ident <- resultToMonad $ valFromObj "identifier" profile - let pairs = fromJSObject profile - pairs' = filter (\(k, _) -> k /= "identifier") pairs - pairs'' = map fromJust . filter isJust . map takeString $ pairs' - return $ Identifier ident pairs'' - -takeString :: (String, JSValue) -> Maybe (String, String) -takeString (k, JSString v) = Just (k, fromJSString v) -takeString _ = Nothing - -getObject :: Monad m => JSValue -> m (JSObject JSValue) -getObject (JSObject o) = return o -getObject _ = fail "Not an object" + b <- wget "https://rpxnow.com/api/v2/auth_info" + [] + [ ("apiKey", apiKey) + , ("token", token) + ] + o <- decode $ pack b + m <- fromMapping o + stat <- lookupScalar "stat" m + unless (stat == "ok") $ failure $ AuthenticateException $ + "Rpxnow login not accepted: " ++ stat ++ "\n" ++ b + parseProfile m -resultToMonad :: Monad m => Result a -> m a -resultToMonad (Ok x) = return x -resultToMonad (Error s) = fail s +parseProfile :: (Monad m, Failure ObjectExtractError m) + => [(String, StringObject)] -> m Identifier +parseProfile m = do + profile <- lookupMapping "profile" m + ident <- lookupScalar "identifier" profile + let profile' = mapMaybe go profile + return $ Identifier ident profile' + where + go ("identifier", _) = Nothing + go (k, Scalar v) = Just (k, v) + go _ = Nothing diff --git a/authenticate.cabal b/authenticate.cabal --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.6.0.2 +version: 0.6.2 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -13,22 +13,15 @@ build-type: Simple homepage: http://github.com/snoyberg/authenticate/tree/master -flag transformers_02 - description: transformers = 0.2.* - library build-depends: base >= 4 && < 5, - json >= 0.4.3 && < 0.5, + data-object >= 0.3.1 && < 0.4, + data-object-json >= 0.3.1 && < 0.4, http-wget >= 0.6 && < 0.7, tagsoup >= 0.6 && < 0.10, - failure >= 0.0.0 && < 0.1, - safe-failure >= 0.4 && < 0.5, - syb - if flag(transformers_02) - build-depends: transformers >= 0.2 && < 0.3 - CPP-OPTIONS: -DTRANSFORMERS_02 - else - build-depends: transformers >= 0.1 && < 0.2 + failure >= 0.0.0 && < 0.2, + transformers >= 0.1 && < 0.3, + bytestring >= 0.9 && < 0.10 exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId ghc-options: -Wall -fno-warn-orphans