Switch to data-object-json

Web/Authenticate/OpenId.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE PackageImports #-}
 ---------------------------------------------------------
 -- |
 -- Module        : Web.Authenticate.OpenId
@@ -19,20 +20,21 @@ module Web.Authenticate.OpenId
     ( 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 @@ instance Monad Error where
     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 @@ 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, '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 @@ authenticate req = do -- FIXME check openid.mode == id_res (not cancel)
     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 @@ getAuthUrl req = do
                 ]
             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

Web/Authenticate/Rpxnow.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE PackageImports #-}
 ---------------------------------------------------------
 --
 -- Module        : Web.Authenticate.Rpxnow
@@ -18,15 +19,19 @@ module Web.Authenticate.Rpxnow
     , 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 @@ data Identifier = Identifier
     }
 
 -- | 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
+    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
 
-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"
-
-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

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 <michael@snoyman.com>
@@ -13,22 +13,15 @@ cabal-version:   >= 1.2
 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