OpenId uses xml-enumerator and tagsoup

OpenId2/Discovery.hs

@@ -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)
+                . mapMaybe linkTag
-                . linkTags
+                . parseTags
-                . htmlTags
   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 :: [Tag Text] -> [(Text, Text)]
-linkTags  = mapMaybe f . filter p
+linkTag (TagOpen "link" as) = let x = (,) <$> lookup "rel" as <*> lookup "href" as in traceShow x x
-  where
+linkTag x = Nothing
-    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

OpenId2/Types.hs

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

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 Control.Monad
+import Data.Maybe (listToMaybe)
-import Data.List
+import Text.XML.Enumerator.Resolved (parseLBS, decodeEntities)
-import Data.Maybe
+import Text.XML.Enumerator.Cursor (fromDocument, element, content, ($/), (&|), Cursor, (&/), attribute, node)
-import Text.XML.Light
+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]
+  { serviceTypes      :: [Text]
-  , serviceMediaTypes :: [String]
+  , serviceMediaTypes :: [Text]
-  , serviceURIs       :: [String]
+  , serviceURIs       :: [Text]
-  , serviceLocalIDs   :: [String]
+  , 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.
+parseXRDS' :: Cursor -> [[Service]]
-tag :: String -> Element -> Bool
+parseXRDS' = element "{xri://$xrds}XRDS" &/
-tag n el = qName (elName el) == n
+             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
+parseService :: Cursor -> [Service]
-findAttr' :: (QName -> Bool) -> Element -> Maybe String
+parseService c =
-findAttr' p el = attrVal `fmap` find (p . attrKey) (elAttribs el)
+    if null types then [] else [Service
-
+        { serviceTypes = types
-
+        , serviceMediaTypes = mtypes
--- | Read, maybe
+        , serviceURIs = uris
-readMaybe :: Read a => String -> Maybe a
+        , serviceLocalIDs = localids
-readMaybe str = case reads str of
+        , servicePriority = listToMaybe (attribute "priority" c) >>= readMaybe
-  [(x,"")] -> Just x
+        }]
-  _        -> Nothing
+  where
-
+    types = c $/ element "{xri://$xrd*($v*2.0)}Type" &/ content
-
+    mtypes = c $/ element "{xri://$xrd*($v*2.0)}MediaType" &/ content
--- | Get the text of an element
+    uris = c $/ element "{xri://$xrd*($v*2.0)}URI" &/ content
-getText :: Element -> String
+    localids = c $/ element "{xri://$xrd*($v*2.0)}LocalID" &/ content
-getText el = case elContent el of
+    readMaybe t =
-  [Text cd] -> cdData cd
+        case Data.Text.Read.signed Data.Text.Read.decimal t of
-  _         -> []
+            Right (i, "") -> Just i
-
+            _ -> Nothing
--- 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
-                   }

Web/Authenticate/Internal.hs

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

Web/Authenticate/OpenId.hs

@@ -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 Data.Text.Lazy.Encoding (decodeUtf8With)
-import qualified Data.ByteString.Lazy.UTF8 as BSLU
+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"

authenticate.cabal

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

openid2.hs

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