authenticate 0.6.0.2 → 0.6.2

raw patch · 3 files changed

+69/−72 lines, 3 filesdep +bytestringdep +data-objectdep +data-object-jsondep −jsondep −safe-failuredep −sybdep ~failuredep ~transformersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: bytestring, data-object, data-object-json

Dependencies removed: json, safe-failure, syb

Dependency ranges changed: failure, transformers

API changes (from Hackage documentation)

Files

• Web/Authenticate/OpenId.hs +26/−19
• Web/Authenticate/Rpxnow.hs +37/−40
• authenticate.cabal +6/−13

@@ -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

@@ -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

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