30 import qualified Codec.Binary.Base64 as B64
31 import qualified Codec.Binary.UTF8.String as UTF8
33 import Control.Arrow.ArrowIO
34 import Control.Arrow.ArrowList
35 import qualified Data.ByteString.Lazy as Lazy (ByteString)
36 import qualified Data.ByteString.Lazy as L hiding (ByteString)
39 import qualified Data.Map as M
42 import Network.HTTP.Lucu hiding (redirect)
43 import Network.URI hiding (fragment)
45 import Rakka.W3CDateTime
46 import Subversion.Types
47 import System.FilePath.Posix
48 import Text.XML.HXT.Arrow.XmlArrow
49 import Text.XML.HXT.Arrow.XmlNodeSet
50 import Text.XML.HXT.DOM.TypeDefs
53 type PageName = String
55 type LanguageTag = String -- See RFC 3066: http://www.ietf.org/rfc/rfc3066.txt
56 type LanguageName = String -- i.e. "日本語"
61 redirName :: !PageName
62 , redirDest :: !PageName
63 , redirRevision :: RevNum
64 , redirLastMod :: UTCTime
65 , redirUpdateInfo :: Maybe UpdateInfo
68 entityName :: !PageName
69 , entityType :: !MIMEType
70 , entityLanguage :: !(Maybe LanguageTag)
71 , entityIsTheme :: !Bool -- text/css 以外では無意味
72 , entityIsFeed :: !Bool -- text/x-rakka 以外では無意味
73 , entityIsLocked :: !Bool
74 , entityIsBinary :: !Bool
75 , entityRevision :: RevNum
76 , entityLastMod :: UTCTime
77 , entitySummary :: !(Maybe String)
78 , entityOtherLang :: !(Map LanguageTag PageName)
79 , entityContent :: !Lazy.ByteString
80 , entityUpdateInfo :: Maybe UpdateInfo
87 uiOldRevision :: !RevNum
88 , uiOldName :: !(Maybe PageName)
93 isRedirect :: Page -> Bool
94 isRedirect (Redirection _ _ _ _ _) = True
98 isEntity :: Page -> Bool
99 isEntity (Entity _ _ _ _ _ _ _ _ _ _ _ _ _) = True
103 pageName :: Page -> PageName
105 | isRedirect p = redirName p
106 | isEntity p = entityName p
107 | otherwise = error "neither redirection nor entity"
110 pageUpdateInfo :: Page -> Maybe UpdateInfo
112 | isRedirect p = redirUpdateInfo p
113 | isEntity p = entityUpdateInfo p
114 | otherwise = error "neither redirection nor entity"
117 pageRevision :: Page -> RevNum
119 | isRedirect p = redirRevision p
120 | isEntity p = entityRevision p
121 | otherwise = error "neither redirection nor entity"
124 -- UTF-8 に encode してから 0x20 - 0x7E の範圍を除いて URI escape する。
125 encodePageName :: PageName -> FilePath
126 encodePageName = escapeURIString isSafeChar . UTF8.encodeString . fixPageName
128 fixPageName :: PageName -> PageName
129 fixPageName = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
132 isSafeChar :: Char -> Bool
135 | isReserved c = False
136 | c > ' ' && c <= '~' = True
140 -- URI unescape して UTF-8 から decode する。
141 decodePageName :: FilePath -> PageName
142 decodePageName = UTF8.decodeString . unEscapeString
145 encodeFragment :: String -> String
146 encodeFragment = escapeURIString isSafeChar . UTF8.encodeString
149 mkPageURI :: URI -> PageName -> URI
150 mkPageURI baseURI name
152 uriPath = foldl (</>) "/" [uriPath baseURI, encodePageName name ++ ".html"]
156 mkPageFragmentURI :: URI -> PageName -> String -> URI
157 mkPageFragmentURI baseURI name fragment
159 uriPath = foldl (</>) "/" [uriPath baseURI, encodePageName name ++ ".html"]
160 , uriFragment = ('#' : encodeFragment fragment)
164 mkFragmentURI :: String -> URI
165 mkFragmentURI fragment
167 uriFragment = ('#' : encodeFragment fragment)
171 mkObjectURI :: URI -> PageName -> URI
172 mkObjectURI baseURI name
173 = mkAuxiliaryURI baseURI ["object"] name
176 mkAuxiliaryURI :: URI -> [String] -> PageName -> URI
177 mkAuxiliaryURI baseURI basePath name
179 uriPath = foldl (</>) "/" ([uriPath baseURI] ++ basePath ++ [encodePageName name])
183 mkRakkaURI :: PageName -> URI
184 mkRakkaURI name = URI {
186 , uriAuthority = Nothing
187 , uriPath = encodePageName name
196 lang="ja" -- 存在しない場合もある
197 isTheme="no" -- text/css の場合のみ存在
198 isFeed="no" -- text/x-rakka の場合のみ存在
202 lastModified="2000-01-01T00:00:00">
206 </summary> -- 存在しない場合もある
208 <otherLang> -- 存在しない場合もある
209 <link lang="ja" page="Bar/Baz" />
217 SKJaHKS8JK/DH8KS43JDK2aKKaSFLLS...
224 lastModified="2000-01-01T00:00:00" />
226 xmlizePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
229 -> if isRedirect page then
230 xmlizeRedirection -< page
234 xmlizeRedirection :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
237 -> do lastMod <- arrIO (utcToLocalZonedTime . redirLastMod) -< page
240 += sattr "name" (redirName page)
241 += sattr "redirect" (redirDest page)
242 += sattr "revision" (show $ redirRevision page)
243 += sattr "lastModified" (formatW3CDateTime lastMod)
246 xmlizeEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
249 -> do lastMod <- arrIO (utcToLocalZonedTime . entityLastMod) -< page
252 += sattr "name" (pageName page)
253 += sattr "type" (show $ entityType page)
254 += ( case entityLanguage page of
255 Just x -> sattr "lang" x
258 += ( case entityType page of
259 MIMEType "text" "css" _
260 -> sattr "isTheme" (yesOrNo $ entityIsTheme page)
261 MIMEType "text" "x-rakka" _
262 -> sattr "isFeed" (yesOrNo $ entityIsFeed page)
266 += sattr "isLocked" (yesOrNo $ entityIsLocked page)
267 += sattr "isBinary" (yesOrNo $ entityIsBinary page)
268 += sattr "revision" (show $ entityRevision page)
269 += sattr "lastModified" (formatW3CDateTime lastMod)
270 += ( case entitySummary page of
271 Just s -> eelem "summary" += txt s
274 += ( if M.null (entityOtherLang page) then
281 | (lang, name) <- M.toList (entityOtherLang page) ]
283 += ( if entityIsBinary page then
285 += txt (B64.encode $ L.unpack $ entityContent page)
289 += txt (UTF8.decode $ L.unpack $ entityContent page)
295 parseXmlizedPage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
298 -> do updateInfo <- maybeA parseUpdateInfo -< tree
299 redirect <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
301 Nothing -> parseEntity -< (name, tree)
302 Just dest -> returnA -< (Redirection {
305 , redirRevision = undefined
306 , redirLastMod = undefined
307 , redirUpdateInfo = updateInfo
311 parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
314 -> do updateInfo <- maybeA parseUpdateInfo -< tree
316 mimeTypeStr <- withDefault (getXPathTreesInDoc "/page/@type/text()" >>> getText) "" -< tree
318 lang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree
320 isTheme <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no"
321 >>> parseYesOrNo) -< tree
322 isFeed <- (withDefault (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) "no"
323 >>> parseYesOrNo) -< tree
324 isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
325 >>> parseYesOrNo) -< tree
327 summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
329 >>> deleteIfEmpty)) -< tree
331 otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link"
333 (getAttrValue0 "lang"
335 getAttrValue0 "page")) -< tree
337 textData <- maybeA (getXPathTreesInDoc "/page/textData/text()" >>> getText) -< tree
338 binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
340 let (isBinary, content)
341 = case (textData, binaryData) of
342 (Just text, Nothing ) -> (False, L.pack $ UTF8.encode text )
343 (Nothing , Just binary) -> (True , L.pack $ B64.decode binary)
344 _ -> error "one of textData or binaryData is required"
347 if null mimeTypeStr then
348 guessMIMEType content
356 , entityType = mimeType
357 , entityLanguage = lang
358 , entityIsTheme = isTheme
359 , entityIsFeed = isFeed
360 , entityIsLocked = isLocked
361 , entityIsBinary = isBinary
362 , entityRevision = undefined
363 , entityLastMod = undefined
364 , entitySummary = summary
365 , entityOtherLang = M.fromList otherLang
366 , entityContent = content
367 , entityUpdateInfo = updateInfo
371 parseUpdateInfo :: (ArrowXml a, ArrowChoice a) => a XmlTree UpdateInfo
374 -> do uInfo <- getXPathTreesInDoc "/page/updateInfo" -< tree
375 oldRev <- (getAttrValue0 "oldRevision" >>> arr read) -< uInfo
376 oldName <- maybeA (getXPathTrees "/updateInfo/move/@from/text()" >>> getText) -< uInfo
377 returnA -< UpdateInfo {
378 uiOldRevision = oldRev
379 , uiOldName = oldName