authenticate 0.9.1.7 → 0.9.2
raw patch · 8 files changed
+126/−171 lines, 8 filesdep +xml-enumeratordep −utf8-stringdep −xmlPVP ok
version bump matches the API change (PVP)
Dependencies added: xml-enumerator
Dependencies removed: utf8-string, xml
API changes (from Hackage documentation)
+ Web.Authenticate.BrowserId: browserIdJs :: Text
+ Web.Authenticate.BrowserId: checkAssertion :: Text -> Text -> IO (Maybe Text)
Files
- OpenId2/Discovery.hs +21/−54
- OpenId2/Types.hs +1/−1
- OpenId2/XRDS.hs +42/−66
- Web/Authenticate/BrowserId.hs +37/−0
- Web/Authenticate/Internal.hs +1/−28
- Web/Authenticate/OAuth.hs +2/−2
- Web/Authenticate/OpenId.hs +19/−17
- authenticate.cabal +3/−3
OpenId2/Discovery.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- |@@ -21,12 +22,12 @@ import OpenId2.Types import OpenId2.XRDS +import Debug.Trace -- 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 (liftIO))@@ -34,8 +35,14 @@ import Control.Monad (mplus, liftM) import qualified Data.CaseInsensitive as CI import Data.Text (Text, pack, unpack)+import Data.Text.Lazy (toStrict)+import qualified Data.Text as T+import Data.Text.Lazy.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import Text.HTML.TagSoup (parseTags, Tag (TagOpen))+import Control.Applicative ((<$>), (<*>)) -data Discovery = Discovery1 String (Maybe String)+data Discovery = Discovery1 Text (Maybe Text) | Discovery2 Provider Identifier IdentType deriving Show @@ -82,7 +89,8 @@ case mloc' of Just loc -> discoverYADIS ident (Just loc) (redirects - 1) Nothing -> do- let mdoc = parseXRDS $ BSLU.toString $ responseBody res+ let mdoc = parseXRDS $ responseBody res+ liftIO $ print mdoc case mdoc of Just doc -> return $ parseYADIS ident doc Nothing -> return Nothing@@ -96,7 +104,7 @@ where isOpenId svc = do let tys = serviceTypes svc- localId = maybe ident (Identifier . pack) $ listToMaybe $ serviceLocalIDs svc+ localId = maybe ident Identifier $ listToMaybe $ serviceLocalIDs svc f (x,y) | x `elem` tys = Just y | otherwise = Nothing (lid, itype) <- listToMaybe $ mapMaybe f@@ -118,72 +126,31 @@ => Identifier -> m (Maybe Discovery) discoverHTML ident'@(Identifier ident) =- (parseHTML ident' . BSLU.toString) `liftM` simpleHttp (unpack ident)+ (parseHTML ident' . toStrict . decodeUtf8With lenientDecode) `liftM` simpleHttp (unpack ident) -- | Parse out an OpenID endpoint and an actual identifier from an HTML -- document.-parseHTML :: Identifier -> String -> Maybe Discovery+parseHTML :: Identifier -> Text -> Maybe Discovery parseHTML ident = resolve . filter isOpenId- . map (dropQuotes *** dropQuotes)- . linkTags- . htmlTags+ . mapMaybe linkTag+ . parseTags where- isOpenId (rel,_) = "openid" `isPrefixOf` rel+ isOpenId (rel, x) = "openid" `T.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 . pack) $ lookup "openid2.local_id" ls+ let lid = maybe ident Identifier $ lookup "openid2.local_id" ls -- Based on OpenID 2.0 spec, section 7.3.3, HTML discovery can only -- result in a claimed identifier. return $ Discovery2 (Provider prov) lid ClaimedIdent 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+--linkTags :: [Tag Text] -> [(Text, Text)]+linkTag (TagOpen "link" as) = let x = (,) <$> lookup "rel" as <*> lookup "href" as in traceShow x x+linkTag x = Nothing
OpenId2/Types.hs view
@@ -24,7 +24,7 @@ import Data.Text (Text) -- | An OpenID provider.-newtype Provider = Provider { providerURI :: String } deriving (Eq,Show)+newtype Provider = Provider { providerURI :: Text } deriving (Eq,Show) -- | A valid OpenID identifier. newtype Identifier = Identifier { identifier :: Text }
OpenId2/XRDS.hs view
@@ -1,4 +1,4 @@-+{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- | -- Module : Text.XRDS@@ -20,12 +20,13 @@ ) where -- Libraries-import Control.Arrow-import Control.Monad-import Data.List-import Data.Maybe-import Text.XML.Light-+import Control.Monad ((>=>))+import Data.Maybe (listToMaybe)+import Text.XML.Enumerator.Resolved (parseLBS, decodeEntities)+import Text.XML.Enumerator.Cursor (fromDocument, element, content, ($/), (&|), Cursor, (&/), attribute, node)+import qualified Data.ByteString.Lazy as L+import Data.Text (Text)+import qualified Data.Text.Read -- Types ----------------------------------------------------------------------- @@ -34,68 +35,43 @@ type XRD = [Service] data Service = Service- { serviceTypes :: [String]- , serviceMediaTypes :: [String]- , serviceURIs :: [String]- , serviceLocalIDs :: [String]+ { serviceTypes :: [Text]+ , serviceMediaTypes :: [Text]+ , serviceURIs :: [Text]+ , serviceLocalIDs :: [Text] , 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-+parseXRDS :: L.ByteString -> Maybe XRDS+parseXRDS str =+ either+ (const Nothing)+ (Just . parseXRDS' . fromDocument)+ (parseLBS str decodeEntities) -parseXRD :: Element -> XRD-parseXRD el =- let svcs = filterChildren (tag "Service") el- in mapMaybe parseService svcs+parseXRDS' :: Cursor -> [[Service]]+parseXRDS' = element "{xri://$xrds}XRDS" &/+ element "{xri://$xrd*($v*2.0)}XRD" &|+ parseXRD +parseXRD :: Cursor -> [Service]+parseXRD c = c $/ element "{xri://$xrd*($v*2.0)}Service" >=> parseService -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- }+parseService :: Cursor -> [Service]+parseService c =+ if null types then [] else [Service+ { serviceTypes = types+ , serviceMediaTypes = mtypes+ , serviceURIs = uris+ , serviceLocalIDs = localids+ , servicePriority = listToMaybe (attribute "priority" c) >>= readMaybe+ }]+ where+ types = c $/ element "{xri://$xrd*($v*2.0)}Type" &/ content+ mtypes = c $/ element "{xri://$xrd*($v*2.0)}MediaType" &/ content+ uris = c $/ element "{xri://$xrd*($v*2.0)}URI" &/ content+ localids = c $/ element "{xri://$xrd*($v*2.0)}LocalID" &/ content+ readMaybe t =+ case Data.Text.Read.signed Data.Text.Read.decimal t of+ Right (i, "") -> Just i+ _ -> Nothing
+ Web/Authenticate/BrowserId.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}+module Web.Authenticate.BrowserId+ ( browserIdJs+ , checkAssertion+ ) where++import Data.Text (Text)+import Network.HTTP.Enumerator (parseUrl, responseBody, httpLbs, queryString, withManager)+import Network.HTTP.Types (queryTextToQuery)+import Data.Aeson (json, Value (Object, String))+import Data.Attoparsec.Lazy (parse, maybeResult)+import qualified Data.Map as Map++-- | Location of the Javascript file hosted by browserid.org+browserIdJs :: Text+browserIdJs = "https://browserid.org/include.js"++checkAssertion :: Text -- ^ audience+ -> Text -- ^ assertion+ -> IO (Maybe Text)+checkAssertion audience assertion = do+ req' <- parseUrl "https://browserid.org/verify"+ let req = req'+ { queryString = queryTextToQuery+ [ ("audience", Just audience)+ , ("assertion", Just assertion)+ ]+ }+ res <- withManager $ httpLbs req+ let lbs = responseBody res+ return $ maybeResult (parse json lbs) >>= getEmail+ where+ getEmail (Object o) =+ case (Map.lookup "status" o, Map.lookup "email" o) of+ (Just (String "okay"), Just (String e)) -> Just e+ _ -> Nothing+ getEmail _ = Nothing
Web/Authenticate/Internal.hs view
@@ -1,11 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-} module Web.Authenticate.Internal- ( qsEncode- , qsUrl- , AuthenticateException (..)+ ( AuthenticateException (..) ) where -import Codec.Binary.UTF8.String (encode) import Numeric (showHex) import Data.List (intercalate) import Data.Typeable (Typeable)@@ -18,27 +15,3 @@ | AuthenticationException String deriving (Show, Typeable) instance Exception AuthenticateException--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 =- concatMap go . encode- where- go 32 = "+" -- space- go 46 = "."- go 45 = "-"- go 126 = "~"- go 95 = "_"- go c- | 48 <= c && c <= 57 = [w2c c]- | 65 <= c && c <= 90 = [w2c c]- | 97 <= c && c <= 122 = [w2c c]- go c = '%' : showHex c ""- w2c = toEnum . fromEnum
Web/Authenticate/OAuth.hs view
@@ -14,7 +14,6 @@ paramEncode ) where import Network.HTTP.Enumerator-import Web.Authenticate.Internal (qsUrl) import Data.Data import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL@@ -38,6 +37,7 @@ import Data.Monoid (mconcat) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.IORef (newIORef, readIORef, atomicModifyIORef)+import Network.HTTP.Types (renderSimpleQuery) -- | Data type for OAuth client (consumer). data OAuth = OAuth { oauthServerName :: String -- ^ Service name@@ -103,7 +103,7 @@ authorizeUrl :: OAuth -- ^ OAuth Application -> Credential -- ^ Temporary Credential (Request Token & Secret) -> String -- ^ URL to authorize-authorizeUrl oa cr = qsUrl (oauthAuthorizeUri oa) [("oauth_token", BS.unpack $ token cr)]+authorizeUrl oa cr = oauthAuthorizeUri oa ++ BS.unpack (renderSimpleQuery True [("oauth_token", token cr)]) -- | Get Access token. getAccessToken, getTokenCredential
Web/Authenticate/OpenId.hs view
@@ -12,19 +12,22 @@ import OpenId2.Discovery (discover, Discovery (..)) import Control.Failure (Failure (failure)) import OpenId2.Types-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 Data.Text.Lazy.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import Data.Text.Lazy (toStrict) import Network.HTTP.Enumerator ( parseUrl, urlEncodedBody, responseBody, httpLbsRedirect , HttpException, withManager )-import Control.Arrow ((***))+import Control.Arrow ((***), second) import Data.List (unfoldr) import Data.Maybe (fromMaybe) import Data.Text (Text, pack, unpack)-import Data.Text.Encoding (encodeUtf8)+import Data.Text.Encoding (encodeUtf8, decodeUtf8)+import Blaze.ByteString.Builder (toByteString)+import Network.HTTP.Types (renderQueryText)+import Data.Monoid (mappend) getForwardUrl :: ( MonadIO m@@ -39,12 +42,11 @@ getForwardUrl openid' complete mrealm params = do let realm = fromMaybe complete mrealm disc <- normalize openid' >>= discover+ let helper s q = return $ s `mappend` decodeUtf8 (toByteString $ renderQueryText True $ map (second Just) q) case disc of- Discovery1 server mdelegate ->- return $ pack $ qsUrl server- $ map (unpack *** unpack) -- FIXME+ Discovery1 server mdelegate -> helper server $ ("openid.mode", "checkid_setup")- : ("openid.identity", maybe openid' pack mdelegate)+ : ("openid.identity", maybe openid' id mdelegate) : ("openid.return_to", complete) : ("openid.realm", realm) : ("openid.trust_root", complete)@@ -54,14 +56,14 @@ case itype of ClaimedIdent -> i OPIdent -> "http://specs.openid.net/auth/2.0/identifier_select"- return $ pack $ qsUrl p+ helper p $ ("openid.ns", "http://specs.openid.net/auth/2.0") : ("openid.mode", "checkid_setup")- : ("openid.claimed_id", unpack i')- : ("openid.identity", unpack i')- : ("openid.return_to", unpack complete)- : ("openid.realm", unpack realm)- : map (unpack *** unpack) params+ : ("openid.claimed_id", i')+ : ("openid.identity", i')+ : ("openid.return_to", complete)+ : ("openid.realm", realm)+ : params authenticate :: ( MonadIO m@@ -91,10 +93,10 @@ let params' = map (encodeUtf8 *** encodeUtf8) $ ("openid.mode", "check_authentication") : filter (\(k, _) -> k /= "openid.mode") params- req' <- parseUrl endpoint+ req' <- parseUrl $ unpack endpoint let req = urlEncodedBody params' req' rsp <- liftIO $ withManager $ httpLbsRedirect req- let rps = parseDirectResponse $ pack $ BSLU.toString $ responseBody rsp -- FIXME+ let rps = parseDirectResponse $ toStrict $ decodeUtf8With lenientDecode $ responseBody rsp case lookup "is_valid" rps of Just "true" -> return (Identifier ident, rps) _ -> failure $ AuthenticationException "OpenID provider did not validate"
authenticate.cabal view
@@ -1,5 +1,5 @@ name: authenticate-version: 0.9.1.7+version: 0.9.2 license: BSD3 license-file: LICENSE author: Michael Snoyman, Hiromi Ishii@@ -21,9 +21,7 @@ failure >= 0.0.0 && < 0.2, transformers >= 0.1 && < 0.3, bytestring >= 0.9 && < 0.10,- utf8-string >= 0.3 && < 0.4, network >= 2.2.1 && < 2.4,- xml >= 1.3.7 && < 1.4, case-insensitive >= 0.2 && < 0.4, RSA >= 1.0 && < 1.1, time >= 1.1 && < 1.3,@@ -33,12 +31,14 @@ text >= 0.5 && < 1.0, http-types >= 0.6 && < 0.7, enumerator >= 0.4.7 && < 0.5,+ xml-enumerator >= 0.3.4 && < 0.4, blaze-builder >= 0.2 && < 0.4, attoparsec >= 0.9 && < 0.10, tls >= 0.7 && < 0.8, containers exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId,+ Web.Authenticate.BrowserId, Web.Authenticate.OpenId.Providers, Web.Authenticate.OAuth, Web.Authenticate.Facebook