Merged OpenId and OpenId2

OpenId2/Discovery.hs

@@ -17,7 +17,6 @@ module OpenId2.Discovery (
   , Discovery (..)
   ) where
 
-import Debug.Trace -- FIXME
 -- Friends
 import OpenId2.Types
 import OpenId2.XRDS
@@ -61,7 +60,7 @@ discoverYADIS :: Identifier
               -> Maybe String
               -> IO (Maybe (Provider,Identifier))
 discoverYADIS ident mb_loc = do
-    let uri = fromMaybe (getIdentifier ident) mb_loc
+    let uri = fromMaybe (identifier ident) mb_loc
     req <- parseUrl uri
     res <- httpLbs req
     let mloc = lookup "x-xrds-location"
@@ -126,9 +125,10 @@ parseHTML ident = resolve
       prov <- lookup "openid2.provider" ls
       let lid = maybe ident Identifier $ lookup "openid2.local_id" ls
       return $ Discovery2 (Provider prov) lid
-    resolve ls = traceShow ls $ resolve2 ls `mplus` resolve1 ls
+    resolve ls = resolve2 ls `mplus` resolve1 ls
 
 
+-- FIXME this would all be a lot better if it used tagsoup
 -- | Filter out link tags from a list of html tags.
 linkTags :: [String] -> [(String,String)]
 linkTags  = mapMaybe f . filter p

OpenId2/Types.hs

@@ -31,5 +31,5 @@ instance Exception OpenIdException
 newtype Provider = Provider { providerURI :: String } deriving (Eq,Show)
 
 -- | A valid OpenID identifier.
-newtype Identifier = Identifier { getIdentifier :: String }
+newtype Identifier = Identifier { identifier :: String }
-  deriving (Eq,Show,Read)
+  deriving (Eq, Show, Read)

Web/Authenticate/OpenId.hs

@@ -1,152 +1,83 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE PackageImports #-}
----------------------------------------------------------
--- |
--- Module        : Web.Authenticate.OpenId
--- Copyright     : Michael Snoyman
--- License       : BSD3
---
--- Maintainer    : Michael Snoyman <michael@snoyman.com>
--- Stability     : Unstable
--- Portability   : portable
---
--- Provides functionality for being an OpenId consumer.
---
----------------------------------------------------------
 module Web.Authenticate.OpenId
-    ( Identifier (..)
+    ( getForwardUrl
-    , getForwardUrl
     , authenticate
-    , AuthenticateException (..)
+    , OpenIdException (..)
+    , Identifier (..)
     ) where
 
-import Network.HTTP.Enumerator
+import Control.Monad.IO.Class
-import Text.HTML.TagSoup
+import OpenId2.Normalization (normalize)
-import "transformers" Control.Monad.IO.Class
+import OpenId2.Discovery (discover, Discovery (..))
-import Data.Data
+import Control.Failure (Failure (failure))
-import Control.Failure hiding (Error)
+import OpenId2.Types (OpenIdException (..), Identifier (Identifier),
-import Control.Exception
+                      Provider (Provider))
-import Control.Monad (liftM, unless)
-import qualified Data.ByteString.Lazy.Char8 as L8
 import Web.Authenticate.Internal (qsUrl)
-import Data.List (intercalate)
+import Control.Monad (unless)
+import qualified Data.ByteString.UTF8 as BSU
+import qualified Data.ByteString.Lazy.UTF8 as BSLU
+import Network.HTTP.Enumerator
+    (parseUrl, urlEncodedBody, responseBody, httpLbsRedirect)
+import Control.Arrow ((***))
+import Data.List (unfoldr)
+import Data.Maybe (fromMaybe)
 
--- | An openid identifier (ie, a URL).
+getForwardUrl :: (MonadIO m, Failure OpenIdException m)
-newtype Identifier = Identifier { identifier :: String }
-    deriving (Eq, Show)
-
-data Error v = Error String | Ok v
-instance Monad Error where
-    return = Ok
-    Error s >>= _ = Error s
-    Ok v >>= f = f v
-    fail s = Error s
-
--- | Returns a URL to forward the user to in order to login.
-getForwardUrl :: (MonadIO m,
-                  Failure InvalidUrlException m,
-                  Failure HttpException m,
-                  Failure MissingVar 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
+getForwardUrl openid' complete = do
-    bodyIdent' <- simpleHttp openid
+    disc <- normalize openid' >>= discover
-    let bodyIdent = L8.unpack bodyIdent'
+    case disc of
-    server <- getOpenIdVar "server" bodyIdent
+        Discovery1 server mdelegate ->
-    let delegate = maybe openid id
+            return $ qsUrl server
-                 $ getOpenIdVar "delegate" bodyIdent
+                [ ("openid.mode", "checkid_setup")
-    return $ qsUrl server
+                , ("openid.identity", fromMaybe openid' mdelegate)
-                        [ ("openid.mode", "checkid_setup")
+                , ("openid.return_to", complete)
-                        , ("openid.identity", delegate)
+                ]
-                        , ("openid.return_to", complete)
+        Discovery2 (Provider p) (Identifier i) ->
-                        ]
+            return $ qsUrl p
+                [ ("openid.ns", "http://specs.openid.net/auth/2.0")
+                , ("openid.mode", "checkid_setup")
+                , ("openid.claimed_id", i)
+                , ("openid.identity", i)
+                , ("openid.return_to", complete)
+                ]
 
-data MissingVar = MissingVar String
+authenticate :: (MonadIO m, Failure OpenIdException m)
-    deriving (Typeable, Show)
-instance Exception MissingVar
-
-getOpenIdVar :: Failure MissingVar m => String -> String -> m String
-getOpenIdVar var content = do
-    let tags = parseTags content
-    let secs = sections (~== ("<link rel=openid." ++ var ++ ">")) tags
-    secs' <- mhead secs
-    secs'' <- mhead secs'
-    return $ fromAttrib "href" secs''
-    where
-        mhead [] = failure $ MissingVar $ "openid." ++ var
-        mhead (x:_) = return x
-
--- | 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,
-                 Failure AuthenticateException m,
-                 Failure InvalidUrlException m,
-                 Failure HttpException m,
-                 Failure MissingVar m)
              => [(String, String)]
              -> m Identifier
-authenticate req = do
+authenticate params = do
-    unless (lookup "openid.mode" req == Just "id_res") $
+    unless (lookup "openid.mode" params == Just "id_res")
-        failure $ AuthenticateException "authenticate without openid.mode=id_res"
+        $ failure $ AuthenticationException "mode is not id_res"
-    authUrl <- getAuthUrl req
+    ident <- case lookup "openid.identity" params of
-    content <- L8.unpack `liftM` simpleHttp authUrl
+                Just i -> return i
-    if contains "is_valid:true" content
+                Nothing ->
-        then Identifier `liftM` alookup "openid.identity" req
+                    failure $ AuthenticationException "Missing identity"
-        else failure $ AuthenticateException content
+    disc <- normalize ident >>= discover
+    let endpoint = case disc of
+                    Discovery1 p _ -> p
+                    Discovery2 (Provider p) _ -> p
+    let params' = map (BSU.fromString *** BSU.fromString)
+                $ ("openid.mode", "check_authentication")
+                : filter (\(k, _) -> k /= "openid.mode") params
+    req' <- liftIO $ parseUrl endpoint
+    let req = urlEncodedBody params' req'
+    rsp <- liftIO $ httpLbsRedirect req
+    let rps = parseDirectResponse $ BSLU.toString $ responseBody rsp
+    case lookup "is_valid" rps of
+        Just "true" -> return $ Identifier ident
+        _ -> failure $ AuthenticationException "OpenID provider did not validate"
 
-alookup :: (Failure AuthenticateException m, Monad m)
+-- | Turn a response body into a list of parameters.
-        => String
+parseDirectResponse :: String -> [(String, String)]
-        -> [(String, String)]
+parseDirectResponse  = unfoldr step
-        -> m String
+  where
-alookup k x = case lookup k x of
+    step []  = Nothing
-                Just k' -> return k'
+    step str = case split (== '\n') str of
-                Nothing -> failure $ MissingOpenIdParameter k
+      (ps,rest) -> Just (split (== ':') ps,rest)
 
-data AuthenticateException = AuthenticateException String
+split :: (a -> Bool) -> [a] -> ([a],[a])
-                           | MissingOpenIdParameter String
+split p as = case break p as of
-    deriving (Show, Typeable)
+  (xs,_:ys) -> (xs,ys)
-instance Exception AuthenticateException
+  pair      -> pair
-
-getAuthUrl :: (MonadIO m, Failure AuthenticateException m,
-               Failure InvalidUrlException m,
-               Failure HttpException m,
-               Failure MissingVar m)
-           => [(String, String)] -> m String
-getAuthUrl req = do
-    identity <- alookup "openid.identity" req
-    idContent <- simpleHttp identity
-    helper $ L8.unpack idContent
-    where
-        helper idContent = do
-            server <- getOpenIdVar "server" idContent
-            dargs <- mapM makeArg [
-                "assoc_handle",
-                "sig",
-                "signed",
-                "identity",
-                "return_to"
-                ]
-            let sargs = [("openid.mode", "check_authentication")]
-            return $ qsUrl server $ dargs ++ sargs
-        makeArg s = do
-            let k = "openid." ++ s
-            v <- alookup k req
-            return (k, v)
-
-contains :: String -> String -> Bool
-contains [] _ = True
-contains _ [] = False
-contains needle haystack =
-    begins needle haystack ||
-    (contains needle $ tail haystack)
-
-begins :: String -> String -> Bool
-begins [] _ = True
-begins _ [] = False
-begins (x:xs) (y:ys) = x == y && begins xs ys

Web/Authenticate/OpenId2.hs

@@ -1,82 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-module Web.Authenticate.OpenId2
-    ( getForwardUrl
-    , authenticate
-    , OpenIdException (..)
-    ) where
-
-import Control.Monad.IO.Class
-import OpenId2.Normalization (normalize)
-import OpenId2.Discovery (discover, Discovery (..))
-import Control.Failure (Failure (failure))
-import OpenId2.Types (OpenIdException (..), Identifier (Identifier),
-                      Provider (Provider))
-import Web.Authenticate.Internal (qsUrl)
-import Control.Monad (unless)
-import qualified Data.ByteString.UTF8 as BSU
-import qualified Data.ByteString.Lazy.UTF8 as BSLU
-import Network.HTTP.Enumerator
-    (parseUrl, urlEncodedBody, responseBody, httpLbsRedirect)
-import Control.Arrow ((***))
-import Data.List (unfoldr)
-import Data.Maybe (fromMaybe)
-
-getForwardUrl :: (MonadIO m, Failure OpenIdException 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
-    disc <- normalize openid' >>= discover
-    case disc of
-        Discovery1 server mdelegate ->
-            return $ qsUrl server
-                [ ("openid.mode", "checkid_setup")
-                , ("openid.identity", fromMaybe openid' mdelegate)
-                , ("openid.return_to", complete)
-                ]
-        Discovery2 (Provider p) (Identifier i) ->
-            return $ qsUrl p
-                [ ("openid.ns", "http://specs.openid.net/auth/2.0")
-                , ("openid.mode", "checkid_setup")
-                , ("openid.claimed_id", i)
-                , ("openid.identity", i)
-                , ("openid.return_to", complete)
-                ]
-
-authenticate :: (MonadIO m, Failure OpenIdException m)
-             => [(String, String)]
-             -> m String
-authenticate params = do
-    unless (lookup "openid.mode" params == Just "id_res")
-        $ failure $ AuthenticationException "mode is not id_res"
-    ident <- case lookup "openid.identity" params of
-                Just i -> return i
-                Nothing ->
-                    failure $ AuthenticationException "Missing identity"
-    disc <- normalize ident >>= discover
-    let endpoint = case disc of
-                    Discovery1 p _ -> p
-                    Discovery2 (Provider p) _ -> p
-    let params' = map (BSU.fromString *** BSU.fromString)
-                $ ("openid.mode", "check_authentication")
-                : filter (\(k, _) -> k /= "openid.mode") params
-    req' <- liftIO $ parseUrl endpoint
-    let req = urlEncodedBody params' req'
-    rsp <- liftIO $ httpLbsRedirect req
-    let rps = parseDirectResponse $ BSLU.toString $ responseBody rsp
-    case lookup "is_valid" rps of
-        Just "true" -> return ident
-        _ -> failure $ AuthenticationException "OpenID provider did not validate"
-
--- | Turn a response body into a list of parameters.
-parseDirectResponse :: String -> [(String, String)]
-parseDirectResponse  = unfoldr step
-  where
-    step []  = Nothing
-    step str = case split (== '\n') str of
-      (ps,rest) -> Just (split (== ':') ps,rest)
-
-split :: (a -> Bool) -> [a] -> ([a],[a])
-split p as = case break p as of
-  (xs,_:ys) -> (xs,ys)
-  pair      -> pair

Web/Authenticate/Rpxnow.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 ---------------------------------------------------------
 --
 -- Module        : Web.Authenticate.Rpxnow
@@ -18,6 +19,7 @@
 module Web.Authenticate.Rpxnow
     ( Identifier (..)
     , authenticate
+    , RpxnowException (..)
     ) where
 
 import Data.Object
@@ -26,11 +28,11 @@ import Network.HTTP.Enumerator
 import "transformers" Control.Monad.IO.Class
 import Control.Failure
 import Data.Maybe
-import Web.Authenticate.OpenId (AuthenticateException (..))
 import Control.Monad
 import qualified Data.ByteString.Char8 as S
 import qualified Data.ByteString.Lazy.Char8 as L
-import Control.Exception (throwIO)
+import Control.Exception (throwIO, Exception)
+import Data.Typeable (Typeable)
 
 -- | Information received from Rpxnow after a valid login.
 data Identifier = Identifier
@@ -42,7 +44,7 @@ data Identifier = Identifier
 authenticate :: (MonadIO m,
                  Failure HttpException m,
                  Failure InvalidUrlException m,
-                 Failure AuthenticateException m,
+                 Failure RpxnowException m,
                  Failure ObjectExtractError m,
                  Failure JsonDecodeError m)
              => String -- ^ API key given by RPXNOW.
@@ -75,7 +77,7 @@ authenticate apiKey token = do
     o <- decode $ S.concat $ L.toChunks b
     m <- fromMapping o
     stat <- lookupScalar "stat" m
-    unless (stat == "ok") $ failure $ AuthenticateException $
+    unless (stat == "ok") $ failure $ RpxnowException $
         "Rpxnow login not accepted: " ++ stat ++ "\n" ++ L.unpack b
     parseProfile m
 
@@ -90,3 +92,7 @@ parseProfile m = do
     go ("identifier", _) = Nothing
     go (k, Scalar v) = Just (k, v)
     go _ = Nothing
+
+data RpxnowException = RpxnowException String
+    deriving (Show, Typeable)
+instance Exception RpxnowException

authenticate.cabal

@@ -27,7 +27,6 @@ library
                      xml >= 1.3.7 && < 1.4
     exposed-modules: Web.Authenticate.Rpxnow,
                      Web.Authenticate.OpenId,
-                     Web.Authenticate.OpenId2,
                      Web.Authenticate.Facebook
     other-modules:   Web.Authenticate.Internal,
                      OpenId2.Discovery,