authenticate 0.6.5 → 0.6.6

raw patch · 8 files changed

+491/−151 lines, 8 filesdep +networkdep +xmlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: network, xml

API changes (from Hackage documentation)

Files

• OpenId2/Discovery.hs +186/−0
• OpenId2/Normalization.hs +62/−0
• OpenId2/Types.hs +35/−0
• OpenId2/XRDS.hs +101/−0
• Web/Authenticate/Internal.hs +10/−0
• Web/Authenticate/OpenId.hs +78/−144
• Web/Authenticate/Rpxnow.hs +10/−4
• authenticate.cabal +9/−3

@@ -0,0 +1,186 @@+{-# LANGUAGE FlexibleContexts #-}++--------------------------------------------------------------------------------+-- |+-- Module      : Network.OpenID.Discovery+-- Copyright   : (c) Trevor Elliott, 2008+-- License     : BSD3+--+-- Maintainer  : Trevor Elliott <trevor@geekgateway.com>+-- 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

@@ -0,0 +1,62 @@+{-# LANGUAGE FlexibleContexts #-}+--------------------------------------------------------------------------------+-- |+-- Module      : Network.OpenID.Normalization+-- Copyright   : (c) Trevor Elliott, 2008+-- License     : BSD3+--+-- Maintainer  : Trevor Elliott <trevor@geekgateway.com>+-- 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 []

@@ -0,0 +1,35 @@+{-# LANGUAGE DeriveDataTypeable #-}+--------------------------------------------------------------------------------+-- |+-- Module      : Network.OpenID.Types+-- Copyright   : (c) Trevor Elliott, 2008+-- License     : BSD3+--+-- Maintainer  : Trevor Elliott <trevor@geekgateway.com>+-- 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)

@@ -0,0 +1,101 @@++--------------------------------------------------------------------------------+-- |+-- Module      : Text.XRDS+-- Copyright   : (c) Trevor Elliott, 2008+-- License     : BSD3+--+-- Maintainer  : Trevor Elliott <trevor@geekgateway.com>+-- 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+                   }

@@ -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 =

@@ -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 <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 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 (~== ("<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--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

@@ -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

@@ -1,5 +1,5 @@ name:            authenticate-version:         0.6.5+version:         0.6.6 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -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