[Fencommits] fenserve: quote HTML properly

Thu Mar 22 20:27:39 EET 2007

Thu Mar 22 20:27:27 EET 2007  Benja Fallenstein <benja.fallenstein at gmail.com>
  * quote HTML properly
diff -rN -u old-fenserve/Page.stub new-fenserve/Page.stub

--- old-fenserve/Page.stub	2007-03-22 20:27:39.000000000 +0200
+++ new-fenserve/Page.stub	2007-03-22 20:27:39.000000000 +0200
@@ -11,36 +11,47 @@
 import qualified Data.Map
 
 pageHandler :: HTML -> Handler
-pageHandler html _request = return $ mkResult 200 "text/html" (toUTF html)
+pageHandler html _request = 
+    return $ mkResult 200 "text/html" (toUTF $ unHTML html)
 
-type HTML = String
+newtype HTML = HTML { unHTML :: String } deriving (Show,Read,Eq,Ord)
 
-genAttr :: (String, String) -> HTML
-genAttr (n,v) = " " ++ n ++ "=\"" ++ v ++ "\""
-
-genTag :: (Maybe a, String) -> [(String, String)] -> [HTML] -> HTML
-genTag (Nothing, s) attrs children = 
-    "<"++s++concatMap genAttr attrs++">" ++ concat children ++ "</"++s++">"
+hquote :: String -> HTML
+hquote ('<':cs) = HTML $ "&lt;" ++ unHTML (hquote cs)
+hquote ('&':cs) = HTML $ "&amp;" ++ unHTML (hquote cs)
+hquote ('"':cs) = HTML $ "&quot;" ++ unHTML (hquote cs)
+hquote (c:cs) = HTML $ c : unHTML (hquote cs)
+hquote "" = HTML ""
+
+genAttr :: (String, HTML) -> String
+genAttr (n,v) = " " ++ n ++ "=\"" ++ unHTML v ++ "\""
+
+genTag :: (Maybe a, String) -> [(String, HTML)] -> [HTML] -> HTML
+genTag (Nothing, s) attrs children = HTML $
+    "<"++s++concatMap genAttr attrs++">"++concatMap unHTML children++"</"++s++">"
     
-genETag :: (Maybe a, String) -> [(String, String)] -> HTML
-genETag (Nothing, s) attrs = "<"++s++concatMap genAttr attrs++" />"
+genETag :: (Maybe a, String) -> [(String, HTML)] -> HTML
+genETag (Nothing, s) attrs = HTML $ "<"++s++concatMap genAttr attrs++" />"
 
 pcdata :: String -> HTML
-pcdata s = s
+pcdata = HTML -- need to test: is this supposed to be 'hquote'?
 
-data Attr = String := String
+data Attr = forall a. ToXML a => String := a
 
-toAttribute (n := v) = (n,v)
+toAttribute (n := v) = (n, toXMLs v)
 
 class ToXML a where
     toXMLs :: a -> HTML
 
 instance ToXML HTML where
     toXMLs = id
+
+instance ToXML String where
+    toXMLs = hquote
     
 instance ToXML Integer where
-    toXMLs = show
+    toXMLs = hquote . show
     
 instance ToXML a => ToXML [a] where
-    toXMLs = concatMap toXMLs
+    toXMLs = HTML . concatMap (unHTML . toXMLs)
 
diff -rN -u old-fenserve/edit-demo.page new-fenserve/edit-demo.page
--- old-fenserve/edit-demo.page	2007-03-22 20:27:39.000000000 +0200
+++ new-fenserve/edit-demo.page	2007-03-22 20:27:39.000000000 +0200
@@ -15,7 +15,7 @@
 
     contents <- liftM fromUTF $ wget uri
         
-    return $ mkResult 200 "text/html" $ toUTF $
+    return $ mkResult 200 "text/html" $ toUTF $ unHTML $
         <html>
         <h1>Edit: <% uri %></h1>
         <form action="" method="POST">


