一部のHTMLタグを通すフィルタ
Posted feedbacks - Haskell
validityチェックなしの手抜きですが。。。 Tag Soup というライブラリを使う
see: Tag Soup
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | import Data.Char
import Text.HTML.TagSoup
proc :: Tag Char -> Tag Char
proc tag@(TagOpen t attrs)
| t' == "a" = TagOpen t (filter allowA attrs)
| t' == "br" = TagOpen t []
| t' == "strong" = TagOpen t []
| otherwise = tag
where t' = map toLower t
proc tag = tag
allowA (a,_) = a == "href" || a == "name"
pprTags :: [Tag Char] -> String
pprTags [] = ""
pprTags tags@(TagOpen s attrs : TagClose e : ts)
| map toLower s == "br" = "<br/>" ++ pprTags ts
pprTags (t:ts) = pprTag t ++ pprTags ts
pprTag :: Tag Char -> String
pprTag tag = case tag of
TagOpen t attrs | ignore t -> "<"++pprOpen' t attrs++">"
| otherwise -> pprOpen t attrs
TagClose t | ignore t -> "<"++pprClose' t++">"
| otherwise -> pprClose t
TagText s -> s
TagComment s -> "<!--"++s++"-->"
TagSpecial s c -> "<!"++s++' ':c++">"
TagWarning s -> ""
pprOpen' t [] = t
pprOpen' t attrs = t++' ':unwords (map pprAttr attrs)
pprOpen t attrs = "<" ++ pprOpen' t attrs ++">"
pprClose' t = t
pprClose t = "</" ++ t ++ ">"
pprAttr (a,v) = a++"='"++v++"'"
ignore :: String -> Bool
ignore t = notElem (map toLower t) ["a","strong","br"]
testdata="<a href='www.google.com'>link</a> <blink>and</blink> <strong onClick='alert(\"NG\")'>click<br/>me!</strong>"
-- main = putStrLn . pprTags . map proc . parseTags =<< getContents
main = putStrLn . pprTags . map proc . parseTags $ testdata
{-
*Main> :main
<a href='www.google.com'>link</a> <blink>and<blink> <strong>click<br/>me!</strong>
-}
|
1. パーザ (文字列→構文木) 2. トランスレータ (構文木→構文木) 3. プリンタ (構文木→文字列) と分けて パーザは Tag Soupライブラリのものを使い、 タグのエスケープはトランスレータで行うようにし、 プリンタは自前で書いてみました。 コメントは保存されます。 こちらの方が前の投稿のものよりモジュラリティが 高くなった気がします。 urlエンコーディングによるuriの値表現の validatingは手を抜いておこなっていません。 (元元要求にはなかったような気がしますと言い訳してみる:p)
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 | module Main (main) where
import Data.Char
import Data.Maybe
import Text.HTML.TagSoup
-- Parsing
-- Text.HTML.TagSoup.parseTags :: String -> [Tag Char]
-- Translating
translate :: [Tag Char] -> [Tag Char]
translate = map trans
trans :: Tag Char -> Tag Char
trans tag = case tag of
TagOpen t attrs | ignore t -> escapeTagOpen t attrs
| otherwise -> TagOpen t (filterAttr t attrs)
TagClose t | ignore t -> escapeTagClose t
_ -> tag
ignore :: String -> Bool
ignore = flip notElem (map fst filterTable) . map toLower
escapeTagOpen t attrs
= TagText $ "<"++t++escape (' ':unwords (map showAttr attrs))++">"
escapeTagClose t
= TagText $ "</"++t++">"
filterAttr :: String -> [Attribute Char] -> [Attribute Char]
filterAttr t = filter ((maybe (const True) id (lookup t filterTable)) . fst)
filterTable :: [(String,String->Bool)]
filterTable = [("a",flip elem ["href","name"])
,("strong",const False)
,("br",const False)]
-- Showing
showTags :: [Tag Char] -> String
showTags [] = ""
showTags (TagOpen s attrs : TagClose e : ts) | isEmptyTag e
= angle (s ++ ' ':unwords (map showAttr attrs)++" /")++showTags ts
showTags (t:ts)
= showTag t ++ showTags ts
showTag tag = case tag of
TagOpen t attrs -> angle $ t ++ ' ':unwords (map showAttr attrs)
TagClose t -> angle $ t ++ "/"
TagText s -> s
TagComment c -> angle $ "!--" ++ c ++ "--"
TagSpecial s t -> angle $ "!" ++ s ++ ' ':t
TagWarning s -> ""
angle :: String -> String
angle s = "<"++s++">"
isEmptyTag :: String -> Bool
isEmptyTag = flip elem ["br","hr"] -- not full fledged
showAttr :: Attribute Char -> String
showAttr (a,v) = a ++ "=" ++ q v
where q v = if elem sq v then dq:v++[dq]
else sq:v++[sq]
sq = '\''
dq = '\"'
escape :: String -> String
escape = concatMap esc
where esc '<' = "<"
esc '>' = ">"
esc '&' = "&"
esc c = [c]
--
main :: IO ()
-- main = putStrLn . showTags . translate . parseTags =<< getContents
main = do { putStrLn . showTags . translate . parseTags $ testdata1
; putStrLn . showTags . translate . parseTags $ testdata2
; putStrLn . showTags . translate . parseTags $ testdata3
}
testdata1 = "<script foo=\"<script>alert('bar')</script>\">alert('foo')</script>"
testdata2 = "<script foo=\"<a href='link'>link</a>\">alert('foo')</script>"
testdata3 = "<a href='www.g>oogle.com'>link</a>"
{-
*Main> :main
<script foo="<script>alert('bar')</script>">alert('foo')</script>
<script foo="<a href='link'>link</a>">alert('foo')</script>
<a href='www.g>oogle.com'>link<a/>
-}
|
にしお
#3410()
Rating0/0=0.00
このお題はperezvonさんの提案を元にしています。ありがとうございました。 ただ、いきなりだと難しいかと思ったので、肝の部分以外を先に出題しました。このお題は続編で徐々に難しくなっていきます。
追記：属性に<や>が含まれてしまうケースに漏れのある解答が多いようなのでテストケースを追加します。 これは「この出力なら十分」という意味です。この出力の通りでなければいけないという意味ではありません。 <script foo="<script>alert('bar')</script>">alert('foo')</script> <script foo="<script>alert('bar')</script>">alert('foo')</script> <script foo="<a href='link'>link</a>">alert('foo')</script> <script foo="<a href='link'>link</a>">alert('foo')</script> <a href='www.g>oogle.com'>link</a> <a href="./www.g%3Eoogle.com">link</a>[ reply ]