OpenId uses xml-enumerator and tagsoup
This commit is contained in:
Michael Snoyman
parent
655ab103fd
commit
e2eee534c1
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- |
|
||||
@ -21,6 +22,7 @@ module OpenId2.Discovery (
|
||||
import OpenId2.Types
|
||||
import OpenId2.XRDS
|
||||
|
||||
import Debug.Trace
|
||||
-- Libraries
|
||||
import Data.Char
|
||||
import Data.List
|
||||
@ -34,8 +36,14 @@ import Control.Failure (Failure (failure))
|
||||
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 +90,8 @@ discoverYADIS ident mb_loc redirects = do
|
||||
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 +105,7 @@ parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat
|
||||
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 +127,31 @@ discoverHTML :: ( MonadIO m, Failure HttpException m)
|
||||
=> 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
|
||||
|
||||
@ -24,7 +24,7 @@ import Web.Authenticate.Internal
|
||||
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 }
|
||||
|
||||
108
OpenId2/XRDS.hs
108
OpenId2/XRDS.hs
@ -1,4 +1,4 @@
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
--------------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Text.XRDS
|
||||
@ -20,12 +20,13 @@ module OpenId2.XRDS (
|
||||
) 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 XRDS = [XRD]
|
||||
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 -------------------------------------------------------------------
|
||||
parseXRDS :: L.ByteString -> Maybe XRDS
|
||||
parseXRDS str =
|
||||
either
|
||||
(const Nothing)
|
||||
(Just . parseXRDS' . fromDocument)
|
||||
(parseLBS str decodeEntities)
|
||||
|
||||
-- | Generate a tag name predicate, that ignores prefix and namespace.
|
||||
tag :: String -> Element -> Bool
|
||||
tag n el = qName (elName el) == n
|
||||
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
|
||||
|
||||
-- | 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
|
||||
}
|
||||
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
|
||||
|
||||
@ -19,7 +19,7 @@ data AuthenticateException =
|
||||
deriving (Show, Typeable)
|
||||
instance Exception AuthenticateException
|
||||
|
||||
qsUrl :: String -> [(String, String)] -> String
|
||||
qsUrl :: String -> [(String, String)] -> String -- FIXME remove
|
||||
qsUrl s [] = s
|
||||
qsUrl url pairs =
|
||||
url ++ delim : intercalate "&" (map qsPair pairs)
|
||||
|
||||
@ -14,8 +14,9 @@ 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
|
||||
@ -41,10 +42,10 @@ getForwardUrl openid' complete mrealm params = do
|
||||
disc <- normalize openid' >>= discover
|
||||
case disc of
|
||||
Discovery1 server mdelegate ->
|
||||
return $ pack $ qsUrl server
|
||||
return $ pack $ qsUrl (unpack server)
|
||||
$ map (unpack *** unpack) -- FIXME
|
||||
$ ("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,7 +55,7 @@ getForwardUrl openid' complete mrealm params = do
|
||||
case itype of
|
||||
ClaimedIdent -> i
|
||||
OPIdent -> "http://specs.openid.net/auth/2.0/identifier_select"
|
||||
return $ pack $ qsUrl p
|
||||
return $ pack $ qsUrl (unpack p)
|
||||
$ ("openid.ns", "http://specs.openid.net/auth/2.0")
|
||||
: ("openid.mode", "checkid_setup")
|
||||
: ("openid.claimed_id", unpack i')
|
||||
@ -91,10 +92,10 @@ authenticate params = do
|
||||
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"
|
||||
|
||||
@ -23,7 +23,6 @@ library
|
||||
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,6 +32,7 @@ library
|
||||
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,
|
||||
|
||||
@ -6,7 +6,7 @@ import Data.Maybe (fromMaybe)
|
||||
import Network.HTTP.Enumerator
|
||||
|
||||
data OID = OID
|
||||
mkYesod "OID" [$parseRoutes|
|
||||
mkYesod "OID" [parseRoutes|
|
||||
/ RootR GET
|
||||
/forward ForwardR GET
|
||||
/complete CompleteR GET
|
||||
@ -14,7 +14,7 @@ mkYesod "OID" [$parseRoutes|
|
||||
|
||||
instance Yesod OID where approot _ = "http://localhost:3000"
|
||||
|
||||
getRootR = defaultLayout [$hamlet|\
|
||||
getRootR = defaultLayout [hamlet|\
|
||||
<form action="@{ForwardR}">
|
||||
\OpenId:
|
||||
<input type="text" name="openid_identifier" value="http://">
|
||||
@ -25,7 +25,7 @@ getForwardR = do
|
||||
openid <- runFormGet' $ stringInput "openid_identifier"
|
||||
render <- getUrlRender
|
||||
url <- liftIO $ getForwardUrl openid (render CompleteR) Nothing []
|
||||
redirectString RedirectTemporary url
|
||||
redirectText RedirectTemporary url
|
||||
return ()
|
||||
|
||||
getCompleteR = do
|
||||
@ -33,4 +33,4 @@ getCompleteR = do
|
||||
ident <- liftIO $ authenticate params
|
||||
return $ RepPlain $ toContent $ show ident
|
||||
|
||||
main = warpDebug 3000 OID
|
||||
main = warp 3000 OID
|
||||
|
||||
Loading…
Reference in New Issue
Block a user