From 0da51855ec4e5c26a95f2605cf1849cfd9bc5fa4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 5 Oct 2010 09:05:36 +0200 Subject: [PATCH] Slimmed down code --- OpenId2/Discovery.hs | 28 +++++------ OpenId2/HTTP.hs | 94 ------------------------------------ OpenId2/Normalization.hs | 12 ++--- OpenId2/Types.hs | 96 ++----------------------------------- OpenId2/XRDS.hs | 17 +------ Web/Authenticate/OpenId2.hs | 32 +++++++++---- authenticate.cabal | 1 - 7 files changed, 46 insertions(+), 234 deletions(-) delete mode 100644 OpenId2/HTTP.hs diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs index 2afcc1c5..f4898bb0 100644 --- a/OpenId2/Discovery.hs +++ b/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 - res1 <- liftIO $ discoverYADIS resolve ident Nothing +discover ident@(Identifier i) = do + 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 - -> Identifier +discoverYADIS :: 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) - return (uri,lid) + uri <- listToMaybe $ serviceURIs svc + 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 resolve ident'@(Identifier ident) = +discoverHTML :: Identifier -> IO (Maybe (Provider,Identifier)) +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. diff --git a/OpenId2/HTTP.hs b/OpenId2/HTTP.hs deleted file mode 100644 index 5ca523d5..00000000 --- a/OpenId2/HTTP.hs +++ /dev/null @@ -1,94 +0,0 @@ - --------------------------------------------------------------------------------- --- | --- Module : Network.OpenID.HTTP --- Copyright : (c) Trevor Elliott, 2008 --- License : BSD3 --- --- Maintainer : Trevor Elliott --- 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 diff --git a/OpenId2/Normalization.hs b/OpenId2/Normalization.hs index 0dc4eb4b..203c697c 100644 --- a/OpenId2/Normalization.hs +++ b/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 - validScheme = guard (scheme == "http:" || scheme == "https:") - u = uri { uriFragment = "", uriPath = path } - path | null (uriPath uri) = "/" - | otherwise = uriPath uri + scheme' = uriScheme uri + validScheme = guard (scheme' == "http:" || scheme' == "https:") + u = uri { uriFragment = "", uriPath = path' } + path' | null (uriPath uri) = "/" + | otherwise = uriPath uri fmt u = Identifier $ normalizePathSegments diff --git a/OpenId2/Types.hs b/OpenId2/Types.hs index ad2bf473..95b76ae4 100644 --- a/OpenId2/Types.hs +++ b/OpenId2/Types.hs @@ -11,28 +11,12 @@ -- module OpenId2.Types ( - AssocType(..) - , SessionType(..) - , Association(..) - , Params - , ReturnTo - , Realm - , Resolver - , Provider (..) - , parseProvider - , showProvider - , modifyProvider - , Identifier(..) - , Error(..) - , assocString + Provider (..) + , Identifier (..) , 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) - --- | 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) +newtype Provider = Provider { providerURI :: String } deriving (Eq,Show) -- | A valid OpenID identifier. newtype Identifier = Identifier { getIdentifier :: String } deriving (Eq,Show,Read) - --- | Errors -newtype Error = Error String deriving Show diff --git a/OpenId2/XRDS.hs b/OpenId2/XRDS.hs index 7594f94a..1cfba367 100644 --- a/OpenId2/XRDS.hs +++ b/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 --------------------------------------------------------------------- diff --git a/Web/Authenticate/OpenId2.hs b/Web/Authenticate/OpenId2.hs index b39d8b7c..59498f92 100644 --- a/Web/Authenticate/OpenId2.hs +++ b/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 resolve - return $ qsUrl (show p) + (Provider p, Identifier i) <- normalize openid' >>= discover + return $ qsUrl 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" - -- FIXME check if endpoint is valid for given identity + _ -> 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 diff --git a/authenticate.cabal b/authenticate.cabal index 0b7e3f15..01f26b9e 100644 --- a/authenticate.cabal +++ b/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