Slimmed down code

OpenId2/Discovery.hs

@@ -34,15 +34,14 @@ import Control.Failure (Failure (failure))
 
 -- | Attempt to resolve an OpenID endpoint, and user identifier.
 discover :: (MonadIO m, Failure OpenIdException m)
-         => Resolver IO
+         => Identifier
-         -> Identifier
          -> m (Provider, Identifier)
-discover resolve ident@(Identifier i) = do
+discover ident@(Identifier i) = do
-    res1 <- liftIO $ discoverYADIS resolve ident Nothing
+    res1 <- liftIO $ discoverYADIS ident Nothing
     case res1 of
         Just x -> return x
         Nothing -> do
-            res2 <- liftIO $ discoverHTML resolve ident
+            res2 <- liftIO $ discoverHTML ident
             case res2 of
                 Just x -> return x
                 Nothing -> failure $ DiscoveryException i
@@ -51,11 +50,10 @@ discover resolve ident@(Identifier i) = do
 
 -- | Attempt a YADIS based discovery, given a valid identifier.  The result is
 --   an OpenID endpoint, and the actual identifier for the user.
-discoverYADIS :: Resolver IO
+discoverYADIS :: Identifier
-              -> Identifier
               -> Maybe String
               -> IO (Maybe (Provider,Identifier))
-discoverYADIS resolve ident mb_loc = do
+discoverYADIS ident mb_loc = do
     let uri = fromMaybe (getIdentifier ident) mb_loc
     req <- parseUrl uri
     res <- httpLbs req
@@ -65,7 +63,7 @@ discoverYADIS resolve ident mb_loc = do
     case statusCode res of
         200 ->
           case mloc of
-            Just loc -> discoverYADIS resolve ident (Just $ S8.unpack loc)
+            Just loc -> discoverYADIS ident (Just $ S8.unpack loc)
             Nothing  -> do
               let mdoc = parseXRDS $ BSLU.toString $ responseBody res
               case mdoc of
@@ -91,16 +89,16 @@ parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat
       , ("http://openid.net/signon/1.0"           , localId)
       , ("http://openid.net/signon/1.1"           , localId)
       ]
-    uri <- parseProvider =<< listToMaybe (serviceURIs svc)
+    uri <- listToMaybe $ serviceURIs svc
-    return (uri,lid)
+    return (Provider uri, lid)
 
 
 -- HTML-Based Discovery --------------------------------------------------------
 
 -- | Attempt to discover an OpenID endpoint, from an HTML document.  The result
 -- will be an endpoint on success, and the actual identifier of the user.
-discoverHTML :: Resolver IO -> Identifier -> IO (Maybe (Provider,Identifier))
+discoverHTML :: Identifier -> IO (Maybe (Provider,Identifier))
-discoverHTML resolve ident'@(Identifier ident) =
+discoverHTML ident'@(Identifier ident) =
     parseHTML ident' . BSLU.toString <$> simpleHttp ident
 
 -- | Parse out an OpenID endpoint and an actual identifier from an HTML
@@ -113,9 +111,9 @@ parseHTML ident = resolve
   where
     isOpenId (rel,_) = "openid" `isPrefixOf` rel
     resolve ls = do
-      prov <- parseProvider =<< lookup "openid2.provider" ls
+      prov <- lookup "openid2.provider" ls
       let lid = maybe ident Identifier $ lookup "openid2.local_id" ls
-      return (prov,lid)
+      return (Provider prov,lid)
 
 
 -- | Filter out link tags from a list of html tags.

OpenId2/HTTP.hs

@@ -1,94 +0,0 @@
-
---------------------------------------------------------------------------------
--- |
--- Module      : Network.OpenID.HTTP
--- Copyright   : (c) Trevor Elliott, 2008
--- License     : BSD3
---
--- Maintainer  : Trevor Elliott <trevor@geekgateway.com>
--- Stability   :
--- Portability :
---
-
-module OpenId2.HTTP (
-    -- * Request Interface
-    makeRequest
-
-    -- * Request/Response Parsing and Formatting
-  , parseDirectResponse
-  , formatParams
-  , formatDirectParams
-  , escapeParam
-  , addParams
-  , parseParams
-  ) where
-
--- friends
-import OpenId2.Types
---import Network.OpenID.Utils
-
--- libraries
-import Data.List
-import Network.BSD
-import Network.Socket
-import Network.URI hiding (query)
-import Network.HTTP.Enumerator
-
-
--- | Perform an http request.
---   If the Bool parameter is set to True, redirects from the server will be
---   followed.
-makeRequest :: Bool -> Resolver IO
-makeRequest follow = if follow then httpLbsRedirect else httpLbs
-
--- Parsing and Formatting ------------------------------------------------------
-
--- | Turn a response body into a list of parameters.
-parseDirectResponse :: String -> Params
-parseDirectResponse  = unfoldr step
-  where
-    step []  = Nothing
-    step str = case split (== '\n') str of
-      (ps,rest) -> Just (split (== ':') ps,rest)
-
-
--- | Format OpenID parameters as a query string
-formatParams :: Params -> String
-formatParams  = intercalate "&" . map f
-  where f (x,y) = x ++ "=" ++ escapeParam y
-
-
--- | Format OpenID parameters as a direct response
-formatDirectParams :: Params -> String
-formatDirectParams  = concatMap f
-  where f (x,y) = x ++ ":" ++ y ++ "\n"
-
-
--- | Escape for the query string of a URI
-escapeParam :: String -> String
-escapeParam  = escapeURIString isUnreserved
-
-
--- | Add Parameters to a URI
-addParams :: Params -> URI -> URI
-addParams ps uri = uri { uriQuery = query }
-  where
-    f (k,v) = (k,v)
-    ps' = map f ps
-    query = '?' : formatParams (parseParams (uriQuery uri) ++ ps')
-
-
--- | Parse OpenID parameters out of a url string
-parseParams :: String -> Params
-parseParams xs = case split (== '?') xs of
-  (_,bs) -> unfoldr step bs
-  where
-    step [] = Nothing
-    step bs = case split (== '&') bs of
-      (as,rest) -> case split (== '=') as of
-        (k,v) -> Just ((k, unEscapeString v),rest)
-
-split :: (a -> Bool) -> [a] -> ([a],[a])
-split p as = case break p as of
-  (xs,_:ys) -> (xs,ys)
-  pair      -> pair

OpenId2/Normalization.hs

@@ -21,8 +21,8 @@ import OpenId2.Types
 import Control.Applicative
 import Control.Monad
 import Data.List
-import Network.URI hiding (scheme,path)
 import Control.Failure (Failure (..))
+import Network.URI
 
 normalize :: Failure OpenIdException m => String -> m Identifier
 normalize ident =
@@ -49,11 +49,11 @@ normalizeIdentifier' xri (Identifier str)
 
     norm uri = validScheme >> return u
       where
-        scheme      = uriScheme uri
+        scheme'     = uriScheme uri
-        validScheme = guard (scheme == "http:" || scheme == "https:")
+        validScheme = guard (scheme' == "http:" || scheme' == "https:")
-        u = uri { uriFragment = "", uriPath = path }
+        u = uri { uriFragment = "", uriPath = path' }
-        path | null (uriPath uri) = "/"
+        path' | null (uriPath uri) = "/"
-             | otherwise          = uriPath uri
+              | otherwise          = uriPath uri
 
     fmt u = Identifier
           $ normalizePathSegments

OpenId2/Types.hs

@@ -11,28 +11,12 @@
 --
 
 module OpenId2.Types (
-    AssocType(..)
+    Provider (..)
-  , SessionType(..)
+  , Identifier (..)
-  , Association(..)
-  , Params
-  , ReturnTo
-  , Realm
-  , Resolver
-  , Provider (..)
-  , parseProvider
-  , showProvider
-  , modifyProvider
-  , Identifier(..)
-  , Error(..)
-  , assocString
   , OpenIdException (..)
   ) where
 
 -- Libraries
-import Data.List
-import Data.Word
-import Network.URI
-import Network.HTTP.Enumerator (Request, Response)
 import Control.Exception (Exception)
 import Data.Typeable (Typeable)
 
@@ -43,83 +27,9 @@ data OpenIdException =
   deriving (Show, Typeable)
 instance Exception OpenIdException
 
---------------------------------------------------------------------------------
--- Types
-
--- | Supported association types
-data AssocType = HmacSha1 | HmacSha256
-    deriving (Read,Show)
-
-assocString :: AssocType -> String
-assocString HmacSha1 = "HMAC-SHA1"
-assocString HmacSha256 = "HMAC-SHA256"
-
-{-
-instance Show AssocType where
-    show HmacSha1 = "HMAC-SHA1"
-    show HmacSha256 = "HMAC-SHA256"
-
-instance Read AssocType where
-  readsPrec _ str | "HMAC-SHA1"   `isPrefixOf` str = [(HmacSha1  ,drop  9  str)]
-                  | "HMAC-SHA256" `isPrefixOf` str = [(HmacSha256, drop 11 str)]
-                  | otherwise                      = []
--}
-
--- | Session types for association establishment
-data SessionType = NoEncryption | DhSha1 | DhSha256
-
-instance Show SessionType where
-  show NoEncryption = "no-encryption"
-  show DhSha1       = "DH-SHA1"
-  show DhSha256     = "DH-SHA256"
-
-instance Read SessionType where
-  readsPrec _ str
-    | "no-encryption" `isPrefixOf` str = [(NoEncryption, drop 13 str)]
-    | "DH-SHA1"       `isPrefixOf` str = [(DhSha1, drop 7 str)]
-    | "DH-SHA256"     `isPrefixOf` str = [(DhSha256, drop 9 str)]
-    | otherwise                        = []
-
-
--- | An association with a provider.
-data Association = Association
-  { assocExpiresIn :: Int
-  , assocHandle    :: String
-  , assocMacKey    :: [Word8]
-  , assocType      :: AssocType
-  } deriving (Show,Read)
-
-
--- | Parameter lists for communication with the server
-type Params = [(String,String)]
-
--- | A return to path
-type ReturnTo = String
-
--- | A realm of uris for a provider to inform a user about
-type Realm = String
-
--- | A way to resolve an HTTP request
-type Resolver m = Request -> m Response
-
 -- | An OpenID provider.
-newtype Provider = Provider { providerURI :: URI } deriving (Eq,Show)
+newtype Provider = Provider { providerURI :: String } deriving (Eq,Show)
-
--- | Parse a provider
-parseProvider :: String -> Maybe Provider
-parseProvider  = fmap Provider . parseURI
-
--- | Show a provider
-showProvider :: Provider -> String
-showProvider (Provider uri) = uriToString (const "") uri []
-
--- | Modify the URI in a provider
-modifyProvider :: (URI -> URI) -> Provider -> Provider
-modifyProvider f (Provider uri) = Provider (f uri)
 
 -- | A valid OpenID identifier.
 newtype Identifier = Identifier { getIdentifier :: String }
   deriving (Eq,Show,Read)
-
--- | Errors
-newtype Error = Error String deriving Show

OpenId2/XRDS.hs

@@ -12,13 +12,9 @@
 
 module OpenId2.XRDS (
     -- * Types
-    XRDS, XRD
+    XRDS
   , Service(..)
 
-    -- * Utility Functions
-  , isUsable
-  , hasType
-
     -- * Parsing
   , parseXRDS
   ) where
@@ -48,11 +44,6 @@ data Service = Service
 
 -- Utilities -------------------------------------------------------------------
 
--- | Check to see if an XRDS service description is usable.
-isUsable :: XRDS -> Bool
-isUsable  = not . null . concat
-
-
 -- | Generate a tag name predicate, that ignores prefix and namespace.
 tag :: String -> Element -> Bool
 tag n el = qName (elName el) == n
@@ -76,12 +67,6 @@ getText el = case elContent el of
   [Text cd] -> cdData cd
   _         -> []
 
-
--- | Generate a predicate over Service Types.
-hasType :: String -> Service -> Bool
-hasType ty svc = ty `elem` serviceTypes svc
-
-
 -- Parsing ---------------------------------------------------------------------
 
 

Web/Authenticate/OpenId2.hs

@@ -8,7 +8,6 @@ module Web.Authenticate.OpenId2
 import Control.Monad.IO.Class
 import OpenId2.Normalization (normalize)
 import OpenId2.Discovery (discover)
-import OpenId2.HTTP (makeRequest, parseDirectResponse)
 import Control.Failure (Failure (failure))
 import OpenId2.Types (OpenIdException (..), Identifier (Identifier),
                       Provider (Provider))
@@ -16,17 +15,18 @@ 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)
+import Network.HTTP.Enumerator
+    (parseUrl, urlEncodedBody, responseBody, httpLbsRedirect)
 import Control.Arrow ((***))
+import Data.List (unfoldr)
 
 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
-    let resolve = makeRequest True
+    (Provider p, Identifier i) <- normalize openid' >>= discover
-    (Provider p, Identifier i) <- normalize openid' >>= discover resolve
+    return $ qsUrl p
-    return $ qsUrl (show p)
         [ ("openid.ns", "http://specs.openid.net/auth/2.0")
         , ("openid.mode", "checkid_setup")
         , ("openid.claimed_id", i)
@@ -49,15 +49,29 @@ authenticate params = do
             Just e -> return e
             Nothing ->
                 failure $ AuthenticationException "Missing op_endpoint"
+    (Provider p, Identifier i) <- normalize ident >>= discover
+    unless (endpoint == p) $
+        failure $ AuthenticationException "endpoint does not match discovery"
     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 $ makeRequest True req
+    rsp <- liftIO $ httpLbsRedirect req
     let rps = parseDirectResponse $ BSLU.toString $ responseBody rsp
     case lookup "is_valid" rps of
         Just "true" -> return ident
-        Nothing ->
+        _ -> failure $ AuthenticationException "OpenID provider did not validate"
-            failure $ AuthenticationException "OpenID provider did not validate"
+
-    -- FIXME check if endpoint is valid for given identity
+-- | 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

authenticate.cabal

@@ -31,7 +31,6 @@ library
                      Web.Authenticate.Facebook
     other-modules:   Web.Authenticate.Internal,
                      OpenId2.Discovery,
-                     OpenId2.HTTP,
                      OpenId2.Normalization,
                      OpenId2.Types,
                      OpenId2.XRDS