diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs new file mode 100644 --- /dev/null +++ b/OpenId2/Discovery.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE FlexibleContexts #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Network.OpenID.Discovery +-- Copyright : (c) Trevor Elliott, 2008 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- Stability : +-- Portability : +-- + +module OpenId2.Discovery ( + -- * Discovery + discover + , Discovery (..) + ) where + +-- Friends +import OpenId2.Types +import OpenId2.XRDS + +-- Libraries +import Data.Char +import Data.List +import Data.Maybe +import Network.HTTP.Enumerator +import qualified Data.ByteString.Lazy.UTF8 as BSLU +import qualified Data.ByteString.Char8 as S8 +import Control.Arrow (first, (***)) +import Control.Monad.IO.Class (MonadIO) +import Control.Failure (Failure (failure)) +import Control.Monad (mplus, liftM) + +data Discovery = Discovery1 String (Maybe String) + | Discovery2 Provider Identifier + deriving Show + +-- | Attempt to resolve an OpenID endpoint, and user identifier. +discover :: ( MonadIO m + , Failure OpenIdException m + , Failure HttpException m + , Failure InvalidUrlException m + ) + => Identifier + -> m Discovery +discover ident@(Identifier i) = do + res1 <- discoverYADIS ident Nothing + case res1 of + Just (x, y) -> return $ Discovery2 x y + Nothing -> do + res2 <- discoverHTML ident + case res2 of + Just x -> return x + Nothing -> failure $ DiscoveryException i + +-- YADIS-Based Discovery ------------------------------------------------------- + +-- | Attempt a YADIS based discovery, given a valid identifier. The result is +-- an OpenID endpoint, and the actual identifier for the user. +discoverYADIS :: ( MonadIO m + , Failure HttpException m + , Failure InvalidUrlException m + ) + => Identifier + -> Maybe String + -> m (Maybe (Provider,Identifier)) +discoverYADIS ident mb_loc = do + let uri = fromMaybe (identifier ident) mb_loc + req <- parseUrl uri + res <- httpLbs req + let mloc = lookup "x-xrds-location" + $ map (first $ map toLower . S8.unpack) + $ responseHeaders res + case statusCode res of + 200 -> + case mloc of + Just loc -> discoverYADIS ident (Just $ S8.unpack loc) + Nothing -> do + let mdoc = parseXRDS $ BSLU.toString $ responseBody res + case mdoc of + Just doc -> return $ parseYADIS ident doc + Nothing -> return Nothing + _ -> return Nothing + + +-- | Parse out an OpenID endpoint, and actual identifier from a YADIS xml +-- document. +parseYADIS :: Identifier -> XRDS -> Maybe (Provider,Identifier) +parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat + where + isOpenId svc = do + let tys = serviceTypes svc + localId = maybe ident Identifier $ listToMaybe $ serviceLocalIDs svc + f (x,y) | x `elem` tys = Just y + | otherwise = Nothing + lid <- listToMaybe $ mapMaybe f + [ ("http://specs.openid.net/auth/2.0/server", ident) + -- claimed identifiers + , ("http://specs.openid.net/auth/2.0/signon", localId) + , ("http://openid.net/signon/1.0" , localId) + , ("http://openid.net/signon/1.1" , localId) + ] + 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 :: ( MonadIO m + , Failure HttpException m + , Failure InvalidUrlException m + ) + => Identifier + -> m (Maybe Discovery) +discoverHTML ident'@(Identifier ident) = + (parseHTML ident' . BSLU.toString) `liftM` simpleHttp ident + +-- | Parse out an OpenID endpoint and an actual identifier from an HTML +-- document. +parseHTML :: Identifier -> String -> Maybe Discovery +parseHTML ident = resolve + . filter isOpenId + . map (dropQuotes *** dropQuotes) + . linkTags + . htmlTags + where + isOpenId (rel,_) = "openid" `isPrefixOf` rel + resolve1 ls = do + server <- lookup "openid.server" ls + let delegate = lookup "openid.delegate" ls + return $ Discovery1 server delegate + resolve2 ls = do + prov <- lookup "openid2.provider" ls + let lid = maybe ident Identifier $ lookup "openid2.local_id" ls + return $ Discovery2 (Provider prov) lid + 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 + where + p = ("link " `isPrefixOf`) + f xs = do + let ys = unfoldr splitAttr (drop 5 xs) + x <- lookup "rel" ys + y <- lookup "href" ys + return (x,y) + + +-- | Split a string into strings of html tags. +htmlTags :: String -> [String] +htmlTags [] = [] +htmlTags xs = case break (== '<') xs of + (as,_:bs) -> fmt as : htmlTags bs + (as,[]) -> [as] + where + fmt as = case break (== '>') as of + (bs,_) -> bs + + +-- | Split out values from a key="value" like string, in a way that +-- is suitable for use with unfoldr. +splitAttr :: String -> Maybe ((String,String),String) +splitAttr xs = case break (== '=') xs of + (_,[]) -> Nothing + (key,_:'"':ys) -> f key (== '"') ys + (key,_:ys) -> f key isSpace ys + where + f key p cs = case break p cs of + (_,[]) -> Nothing + (value,_:rest) -> Just ((key,value), dropWhile isSpace rest) + +dropQuotes :: String -> String +dropQuotes s@('\'':x:y) + | last y == '\'' = x : init y + | otherwise = s +dropQuotes s@('"':x:y) + | last y == '"' = x : init y + | otherwise = s +dropQuotes s = s diff --git a/OpenId2/Normalization.hs b/OpenId2/Normalization.hs new file mode 100644 --- /dev/null +++ b/OpenId2/Normalization.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE FlexibleContexts #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Network.OpenID.Normalization +-- Copyright : (c) Trevor Elliott, 2008 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- Stability : +-- Portability : +-- + +module OpenId2.Normalization + ( normalize + ) where + +-- Friends +import OpenId2.Types + +-- Libraries +import Control.Applicative +import Control.Monad +import Data.List +import Control.Failure (Failure (..)) +import Network.URI + +normalize :: Failure OpenIdException m => String -> m Identifier +normalize ident = + case normalizeIdentifier $ Identifier ident of + Just i -> return i + Nothing -> failure $ NormalizationException ident + +-- | Normalize an identifier, discarding XRIs. +normalizeIdentifier :: Identifier -> Maybe Identifier +normalizeIdentifier = normalizeIdentifier' (const Nothing) + + +-- | Normalize the user supplied identifier, using a supplied function to +-- normalize an XRI. +normalizeIdentifier' :: (String -> Maybe String) -> Identifier + -> Maybe Identifier +normalizeIdentifier' xri (Identifier str) + | null str = Nothing + | "xri://" `isPrefixOf` str = Identifier `fmap` xri str + | head str `elem` "=@+$!" = Identifier `fmap` xri str + | otherwise = fmt `fmap` (url >>= norm) + where + url = parseURI str <|> parseURI ("http://" ++ 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 + + fmt u = Identifier + $ normalizePathSegments + $ normalizeEscape + $ normalizeCase + $ uriToString (const "") u [] diff --git a/OpenId2/Types.hs b/OpenId2/Types.hs new file mode 100644 --- /dev/null +++ b/OpenId2/Types.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DeriveDataTypeable #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Network.OpenID.Types +-- Copyright : (c) Trevor Elliott, 2008 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- Stability : +-- Portability : +-- + +module OpenId2.Types ( + Provider (..) + , Identifier (..) + , OpenIdException (..) + ) where + +-- Libraries +import Control.Exception (Exception) +import Data.Typeable (Typeable) + +data OpenIdException = + NormalizationException String + | DiscoveryException String + | AuthenticationException String + deriving (Show, Typeable) +instance Exception OpenIdException + +-- | An OpenID provider. +newtype Provider = Provider { providerURI :: String } deriving (Eq,Show) + +-- | A valid OpenID identifier. +newtype Identifier = Identifier { identifier :: String } + deriving (Eq, Show, Read) diff --git a/OpenId2/XRDS.hs b/OpenId2/XRDS.hs new file mode 100644 --- /dev/null +++ b/OpenId2/XRDS.hs @@ -0,0 +1,101 @@ + +-------------------------------------------------------------------------------- +-- | +-- Module : Text.XRDS +-- Copyright : (c) Trevor Elliott, 2008 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- Stability : +-- Portability : +-- + +module OpenId2.XRDS ( + -- * Types + XRDS + , Service(..) + + -- * Parsing + , parseXRDS + ) where + +-- Libraries +import Control.Arrow +import Control.Monad +import Data.List +import Data.Maybe +import Text.XML.Light + + +-- Types ----------------------------------------------------------------------- + +type XRDS = [XRD] + +type XRD = [Service] + +data Service = Service + { serviceTypes :: [String] + , serviceMediaTypes :: [String] + , serviceURIs :: [String] + , serviceLocalIDs :: [String] + , servicePriority :: Maybe Int + , serviceExtra :: [Element] + } deriving Show + +-- Utilities ------------------------------------------------------------------- + +-- | Generate a tag name predicate, that ignores prefix and namespace. +tag :: String -> Element -> Bool +tag n el = qName (elName el) == n + + +-- | Filter the attributes of an element by some predicate +findAttr' :: (QName -> Bool) -> Element -> Maybe String +findAttr' p el = attrVal `fmap` find (p . attrKey) (elAttribs el) + + +-- | Read, maybe +readMaybe :: Read a => String -> Maybe a +readMaybe str = case reads str of + [(x,"")] -> Just x + _ -> Nothing + + +-- | Get the text of an element +getText :: Element -> String +getText el = case elContent el of + [Text cd] -> cdData cd + _ -> [] + +-- Parsing --------------------------------------------------------------------- + + +parseXRDS :: String -> Maybe XRDS +parseXRDS str = do + doc <- parseXMLDoc str + let xrds = filterChildren (tag "XRD") doc + return $ map parseXRD xrds + + +parseXRD :: Element -> XRD +parseXRD el = + let svcs = filterChildren (tag "Service") el + in mapMaybe parseService svcs + + +parseService :: Element -> Maybe Service +parseService el = do + let vals t x = first (map getText) $ partition (tag t) x + (tys,tr) = vals "Type" (elChildren el) + (mts,mr) = vals "MediaType" tr + (uris,ur) = vals "URI" mr + (lids,rest) = vals "LocalID" ur + priority = readMaybe =<< findAttr' (("priority" ==) . qName) el + guard $ not $ null tys + return $ Service { serviceTypes = tys + , serviceMediaTypes = mts + , serviceURIs = uris + , serviceLocalIDs = lids + , servicePriority = priority + , serviceExtra = rest + } diff --git a/Web/Authenticate/Internal.hs b/Web/Authenticate/Internal.hs --- a/Web/Authenticate/Internal.hs +++ b/Web/Authenticate/Internal.hs @@ -1,9 +1,19 @@ module Web.Authenticate.Internal ( qsEncode + , qsUrl ) where import Codec.Binary.UTF8.String (encode) import Numeric (showHex) +import Data.List (intercalate) + +qsUrl :: String -> [(String, String)] -> String +qsUrl s [] = s +qsUrl url pairs = + url ++ delim : intercalate "&" (map qsPair pairs) + where + qsPair (x, y) = qsEncode x ++ '=' : qsEncode y + delim = if '?' `elem` url then '&' else '?' qsEncode :: String -> String qsEncode = diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -1,159 +1,93 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE PackageImports #-} ---------------------------------------------------------- --- | --- Module : Web.Authenticate.OpenId --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Unstable --- Portability : portable --- --- Provides functionality for being an OpenId consumer. --- ---------------------------------------------------------- module Web.Authenticate.OpenId - ( Identifier (..) - , getForwardUrl + ( getForwardUrl , authenticate - , AuthenticateException (..) + , OpenIdException (..) + , Identifier (..) ) 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 -import Text.HTML.TagSoup -import "transformers" Control.Monad.IO.Class -import Data.Data -import Control.Failure hiding (Error) -import Control.Exception -import Control.Monad (liftM, unless) -import qualified Data.ByteString.Lazy.Char8 as L8 -import Web.Authenticate.Internal (qsEncode) -import Data.List (intercalate) - --- | An openid identifier (ie, a URL). -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 + ( parseUrl, urlEncodedBody, responseBody, httpLbsRedirect + , HttpException, InvalidUrlException + ) +import Control.Arrow ((***)) +import Data.List (unfoldr) +import Data.Maybe (fromMaybe) --- | Returns a URL to forward the user to in order to login. -getForwardUrl :: (MonadIO m, - Failure InvalidUrlException m, - Failure HttpException m, - Failure MissingVar m - ) +getForwardUrl :: ( MonadIO m + , Failure OpenIdException m + , Failure HttpException m + , Failure InvalidUrlException 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 - bodyIdent' <- simpleHttp openid - let bodyIdent = L8.unpack bodyIdent' - server <- getOpenIdVar "server" bodyIdent - let delegate = maybe openid id - $ getOpenIdVar "delegate" bodyIdent - return $ constructUrl server - [ ("openid.mode", "checkid_setup") - , ("openid.identity", delegate) - , ("openid.return_to", complete) - ] - -data MissingVar = MissingVar String - 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 (~== ("")) tags - secs' <- mhead secs - secs'' <- mhead secs' - return $ fromAttrib "href" secs'' - where - mhead [] = failure $ MissingVar $ "openid." ++ var - mhead (x:_) = return x - -constructUrl :: String -> [(String, String)] -> String -constructUrl url [] = url -constructUrl url args = - url ++ "?" ++ intercalate "&" (map qsPair args) - where - qsPair (x, y) = qsEncode x ++ '=' : qsEncode y +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) + ] --- | 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) +authenticate :: ( MonadIO m + , Failure OpenIdException m + , Failure InvalidUrlException m + , Failure HttpException m + ) => [(String, String)] -> m Identifier -authenticate req = do - unless (lookup "openid.mode" req == Just "id_res") $ - failure $ AuthenticateException "authenticate without openid.mode=id_res" - authUrl <- getAuthUrl req - content <- L8.unpack `liftM` simpleHttp authUrl - if contains "is_valid:true" content - then Identifier `liftM` alookup "openid.identity" req - else failure $ AuthenticateException content - -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, 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 $ constructUrl server $ dargs ++ sargs - makeArg s = do - let k = "openid." ++ s - v <- alookup k req - return (k, v) +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' <- parseUrl endpoint + let req = urlEncodedBody params' req' + rsp <- 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" -contains :: String -> String -> Bool -contains [] _ = True -contains _ [] = False -contains needle haystack = - begins needle haystack || - (contains needle $ tail haystack) +-- | 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) -begins :: String -> String -> Bool -begins [] _ = True -begins _ [] = False -begins (x:xs) (y:ys) = x == y && begins xs ys +split :: (a -> Bool) -> [a] -> ([a],[a]) +split p as = case break p as of + (xs,_:ys) -> (xs,ys) + pair -> pair diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs --- a/Web/Authenticate/Rpxnow.hs +++ b/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 "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 @@ 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 @@ 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 @@ go ("identifier", _) = Nothing go (k, Scalar v) = Just (k, v) go _ = Nothing + +data RpxnowException = RpxnowException String + deriving (Show, Typeable) +instance Exception RpxnowException diff --git a/authenticate.cabal b/authenticate.cabal --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.6.5 +version: 0.6.6 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -22,9 +22,15 @@ failure >= 0.0.0 && < 0.2, transformers >= 0.1 && < 0.3, bytestring >= 0.9 && < 0.10, - utf8-string >= 0.3 && < 0.4 + utf8-string >= 0.3 && < 0.4, + network >= 2.2.1 && < 2.3, + xml >= 1.3.7 && < 1.4 exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId, Web.Authenticate.Facebook - other-modules: Web.Authenticate.Internal + other-modules: Web.Authenticate.Internal, + OpenId2.Discovery, + OpenId2.Normalization, + OpenId2.Types, + OpenId2.XRDS ghc-options: -Wall