diff --git a/.gitignore b/.gitignore index 019dac95..c479d6bc 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ *.swp dist +client_session_key.aes diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs new file mode 100644 index 00000000..2afcc1c5 --- /dev/null +++ b/OpenId2/Discovery.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE FlexibleContexts #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Network.OpenID.Discovery +-- Copyright : (c) Trevor Elliott, 2008 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- Stability : +-- Portability : +-- + +module OpenId2.Discovery ( + -- * Discovery + discover + ) 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.Applicative ((<$>)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Failure (Failure (failure)) + +-- | Attempt to resolve an OpenID endpoint, and user identifier. +discover :: (MonadIO m, Failure OpenIdException m) + => Resolver IO + -> Identifier + -> m (Provider, Identifier) +discover resolve ident@(Identifier i) = do + res1 <- liftIO $ discoverYADIS resolve ident Nothing + case res1 of + Just x -> return x + Nothing -> do + res2 <- liftIO $ discoverHTML resolve 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 :: Resolver IO + -> Identifier + -> Maybe String + -> IO (Maybe (Provider,Identifier)) +discoverYADIS resolve ident mb_loc = do + let uri = fromMaybe (getIdentifier 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 resolve 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 <- parseProvider =<< listToMaybe (serviceURIs svc) + return (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) = + parseHTML ident' . BSLU.toString <$> simpleHttp ident + +-- | Parse out an OpenID endpoint and an actual identifier from an HTML +-- document. +parseHTML :: Identifier -> String -> Maybe (Provider,Identifier) +parseHTML ident = resolve + . filter isOpenId + . linkTags + . htmlTags + where + isOpenId (rel,_) = "openid" `isPrefixOf` rel + resolve ls = do + prov <- parseProvider =<< lookup "openid2.provider" ls + let lid = maybe ident Identifier $ lookup "openid2.local_id" ls + return (prov,lid) + + +-- | 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) diff --git a/OpenId2/HTTP.hs b/OpenId2/HTTP.hs new file mode 100644 index 00000000..5ca523d5 --- /dev/null +++ b/OpenId2/HTTP.hs @@ -0,0 +1,94 @@ + +-------------------------------------------------------------------------------- +-- | +-- 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 new file mode 100644 index 00000000..0dc4eb4b --- /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 Network.URI hiding (scheme,path) +import Control.Failure (Failure (..)) + +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 index 00000000..ad2bf473 --- /dev/null +++ b/OpenId2/Types.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE DeriveDataTypeable #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Network.OpenID.Types +-- Copyright : (c) Trevor Elliott, 2008 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- Stability : +-- Portability : +-- + +module OpenId2.Types ( + AssocType(..) + , SessionType(..) + , 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) + +data OpenIdException = + NormalizationException String + | DiscoveryException String + | AuthenticationException String + 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) + +-- | 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 new file mode 100644 index 00000000..7594f94a --- /dev/null +++ b/OpenId2/XRDS.hs @@ -0,0 +1,116 @@ + +-------------------------------------------------------------------------------- +-- | +-- Module : Text.XRDS +-- Copyright : (c) Trevor Elliott, 2008 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- Stability : +-- Portability : +-- + +module OpenId2.XRDS ( + -- * Types + XRDS, XRD + , Service(..) + + -- * Utility Functions + , isUsable + , hasType + + -- * 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 ------------------------------------------------------------------- + +-- | 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 + + +-- | 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 + _ -> [] + + +-- | Generate a predicate over Service Types. +hasType :: String -> Service -> Bool +hasType ty svc = ty `elem` serviceTypes svc + + +-- 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 index 191c6bd7..93e8594a 100644 --- a/Web/Authenticate/Internal.hs +++ b/Web/Authenticate/Internal.hs @@ -1,9 +1,18 @@ 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 ++ "?" ++ intercalate "&" (map qsPair pairs) + where + qsPair (x, y) = qsEncode x ++ '=' : qsEncode y qsEncode :: String -> String qsEncode = diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index 3230ec2c..589498bd 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -31,7 +31,7 @@ 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 Web.Authenticate.Internal (qsUrl) import Data.List (intercalate) -- | An openid identifier (ie, a URL). @@ -60,7 +60,7 @@ getForwardUrl openid complete = do server <- getOpenIdVar "server" bodyIdent let delegate = maybe openid id $ getOpenIdVar "delegate" bodyIdent - return $ constructUrl server + return $ qsUrl server [ ("openid.mode", "checkid_setup") , ("openid.identity", delegate) , ("openid.return_to", complete) @@ -81,13 +81,6 @@ getOpenIdVar var content = do 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 - -- | 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. @@ -140,7 +133,7 @@ getAuthUrl req = do "return_to" ] let sargs = [("openid.mode", "check_authentication")] - return $ constructUrl server $ dargs ++ sargs + return $ qsUrl server $ dargs ++ sargs makeArg s = do let k = "openid." ++ s v <- alookup k req diff --git a/Web/Authenticate/OpenId2.hs b/Web/Authenticate/OpenId2.hs new file mode 100644 index 00000000..b39d8b7c --- /dev/null +++ b/Web/Authenticate/OpenId2.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE FlexibleContexts #-} +module Web.Authenticate.OpenId2 + ( getForwardUrl + , authenticate + , OpenIdException (..) + ) where + +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)) +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 Control.Arrow ((***)) + +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) + [ ("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" + endpoint <- + case lookup "openid.op_endpoint" params of + Just e -> return e + Nothing -> + failure $ AuthenticationException "Missing op_endpoint" + 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 + 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 diff --git a/authenticate.cabal b/authenticate.cabal index 75aecaab..0b7e3f15 100644 --- 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,17 @@ library 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.OpenId2, Web.Authenticate.Facebook - other-modules: Web.Authenticate.Internal + other-modules: Web.Authenticate.Internal, + OpenId2.Discovery, + OpenId2.HTTP, + OpenId2.Normalization, + OpenId2.Types, + OpenId2.XRDS ghc-options: -Wall diff --git a/openid2.hs b/openid2.hs new file mode 100644 index 00000000..4f160b80 --- /dev/null +++ b/openid2.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE TypeFamilies, QuasiQuotes #-} +import Yesod +import Web.Authenticate.OpenId2 +import Data.Object +import Data.Maybe (fromMaybe) +import Network.HTTP.Enumerator + +data OID = OID +mkYesod "OID" [$parseRoutes| +/ RootR GET +/forward ForwardR GET +/complete CompleteR GET +|] + +instance Yesod OID where approot _ = "http://localhost:3000" + +getRootR = defaultLayout [$hamlet| +%form!action=@ForwardR@ + OpenId: + %input!type=text!name=openid_identifier!value="http://" + %input!type=submit +|] + +getForwardR = do + openid <- runFormGet' $ stringInput "openid_identifier" + render <- getUrlRender + url <- liftIO $ getForwardUrl openid $ render CompleteR + redirectString RedirectTemporary url + return () + +getCompleteR = do + params <- reqGetParams `fmap` getRequest + ident <- liftIO $ authenticate params + return $ RepPlain $ toContent ident + +main = withHttpEnumerator $ basicHandler 3000 OID