32 import qualified Codec.Binary.Base64 as B64
33 import Codec.Binary.UTF8.String
35 import Control.Arrow.ArrowIO
36 import Control.Arrow.ArrowList
37 import qualified Data.ByteString.Lazy as Lazy (ByteString)
38 import qualified Data.ByteString.Lazy as L hiding (ByteString)
41 import qualified Data.Map as M
44 import Network.HTTP.Lucu hiding (redirect)
45 import Network.URI hiding (fragment)
47 import Rakka.W3CDateTime
48 import Subversion.Types
49 import System.FilePath.Posix
50 import Text.XML.HXT.Arrow.XmlArrow
51 import Text.XML.HXT.Arrow.XmlNodeSet
52 import Text.XML.HXT.DOM.TypeDefs
55 type PageName = String
57 type LanguageTag = String -- See RFC 3066: http://www.ietf.org/rfc/rfc3066.txt
58 type LanguageName = String -- i.e. "日本語"
63 redirName :: !PageName
64 , redirDest :: !PageName
65 , redirRevision :: RevNum
66 , redirLastMod :: UTCTime
67 , redirUpdateInfo :: Maybe UpdateInfo
70 entityName :: !PageName
71 , entityType :: !MIMEType
72 , entityLanguage :: !(Maybe LanguageTag)
73 , entityFileName :: !(Maybe String)
74 , entityIsTheme :: !Bool -- text/css 以外では無意味
75 , entityIsFeed :: !Bool -- text/x-rakka 以外では無意味
76 , entityIsLocked :: !Bool
77 , entityIsBoring :: !Bool
78 , entityIsBinary :: !Bool
79 , entityRevision :: RevNum
80 , entityLastMod :: UTCTime
81 , entitySummary :: !(Maybe String)
82 , entityOtherLang :: !(Map LanguageTag PageName)
83 , entityContent :: !Lazy.ByteString
84 , entityUpdateInfo :: Maybe UpdateInfo
91 uiOldRevision :: !RevNum
92 , uiOldName :: !(Maybe PageName)
97 isRedirect :: Page -> Bool
98 isRedirect (Redirection _ _ _ _ _) = True
102 isEntity :: Page -> Bool
103 isEntity (Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) = True
107 pageName :: Page -> PageName
109 | isRedirect p = redirName p
110 | isEntity p = entityName p
111 | otherwise = fail "neither redirection nor entity"
114 pageUpdateInfo :: Page -> Maybe UpdateInfo
116 | isRedirect p = redirUpdateInfo p
117 | isEntity p = entityUpdateInfo p
118 | otherwise = fail "neither redirection nor entity"
121 -- UTF-8 に encode してから 0x20 - 0x7E の範圍を除いて URI escape する。
122 encodePageName :: PageName -> FilePath
123 encodePageName = escapeURIString isSafeChar . encodeString . fixPageName
125 fixPageName :: PageName -> PageName
126 fixPageName = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
129 isSafeChar :: Char -> Bool
132 | isReserved c = False
133 | c > ' ' && c <= '~' = True
137 -- URI unescape して UTF-8 から decode する。
138 decodePageName :: FilePath -> PageName
139 decodePageName = decodeString . unEscapeString
142 encodeFragment :: String -> String
143 encodeFragment = escapeURIString isSafeChar . encodeString
146 entityFileName' :: Page -> String
148 = fromMaybe (defaultFileName (entityType page) (entityName page)) (entityFileName page)
151 defaultFileName :: MIMEType -> PageName -> String
152 defaultFileName pType pName
153 = let baseName = takeFileName pName
156 MIMEType "text" "x-rakka" _ -> baseName <.> "rakka"
157 MIMEType "text" "css" _ -> baseName <.> "css"
161 mkPageURI :: URI -> PageName -> URI
162 mkPageURI baseURI name
164 uriPath = foldl (</>) "/" [uriPath baseURI, encodePageName name ++ ".html"]
168 mkPageFragmentURI :: URI -> PageName -> String -> URI
169 mkPageFragmentURI baseURI name fragment
171 uriPath = foldl (</>) "/" [uriPath baseURI, encodePageName name ++ ".html"]
172 , uriFragment = ('#' : encodeFragment fragment)
176 mkFragmentURI :: String -> URI
177 mkFragmentURI fragment
179 uriFragment = ('#' : encodeFragment fragment)
183 mkObjectURI :: URI -> PageName -> URI
184 mkObjectURI baseURI name
185 = mkAuxiliaryURI baseURI ["object"] name
188 mkAuxiliaryURI :: URI -> [String] -> PageName -> URI
189 mkAuxiliaryURI baseURI basePath name
191 uriPath = foldl (</>) "/" ([uriPath baseURI] ++ basePath ++ [encodePageName name])
195 mkRakkaURI :: PageName -> URI
196 mkRakkaURI name = URI {
198 , uriAuthority = Nothing
199 , uriPath = encodePageName name
208 lang="ja" -- 存在しない場合もある
209 fileName="bar.rakka" -- 存在しない場合もある
210 isTheme="no" -- text/css の場合のみ存在
211 isFeed="no" -- text/x-rakka の場合のみ存在
215 lastModified="2000-01-01T00:00:00">
219 </summary> -- 存在しない場合もある
221 <otherLang> -- 存在しない場合もある
222 <link lang="ja" page="Bar/Baz" />
230 SKJaHKS8JK/DH8KS43JDK2aKKaSFLLS...
237 lastModified="2000-01-01T00:00:00" />
239 xmlizePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
242 -> if isRedirect page then
243 xmlizeRedirection -< page
247 xmlizeRedirection :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
250 -> do lastMod <- arrIO (utcToLocalZonedTime . redirLastMod) -< page
253 += sattr "name" (redirName page)
254 += sattr "redirect" (redirDest page)
255 += sattr "revision" (show $ redirRevision page)
256 += sattr "lastModified" (formatW3CDateTime lastMod)
259 xmlizeEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
262 -> do lastMod <- arrIO (utcToLocalZonedTime . entityLastMod) -< page
265 += sattr "name" (pageName page)
266 += sattr "type" (show $ entityType page)
267 += ( case entityLanguage page of
268 Just x -> sattr "lang" x
271 += ( case entityFileName page of
272 Just x -> sattr "fileName" x
275 += ( case entityType page of
276 MIMEType "text" "css" _
277 -> sattr "isTheme" (yesOrNo $ entityIsTheme page)
278 MIMEType "text" "x-rakka" _
279 -> sattr "isFeed" (yesOrNo $ entityIsFeed page)
283 += sattr "isLocked" (yesOrNo $ entityIsLocked page)
284 += sattr "isBoring" (yesOrNo $ entityIsBoring page)
285 += sattr "isBinary" (yesOrNo $ entityIsBinary page)
286 += sattr "revision" (show $ entityRevision page)
287 += sattr "lastModified" (formatW3CDateTime lastMod)
288 += ( case entitySummary page of
289 Just s -> eelem "summary" += txt s
292 += ( if M.null (entityOtherLang page) then
299 | (lang, name) <- M.toList (entityOtherLang page) ]
301 += ( if entityIsBinary page then
303 += txt (B64.encode $ L.unpack $ entityContent page)
307 += txt (decode $ L.unpack $ entityContent page)
313 parseXmlizedPage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
316 -> do updateInfo <- maybeA parseUpdateInfo -< tree
317 redirect <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
319 Nothing -> parseEntity -< (name, tree)
320 Just dest -> returnA -< (Redirection {
323 , redirRevision = undefined
324 , redirLastMod = undefined
325 , redirUpdateInfo = updateInfo
329 parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
332 -> do updateInfo <- maybeA parseUpdateInfo -< tree
334 mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText
335 >>> arr read) -< tree
337 lang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree
338 fileName <- maybeA (getXPathTreesInDoc "/page/@filename/text()" >>> getText) -< tree
340 isTheme <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no"
341 >>> parseYesOrNo) -< tree
342 isFeed <- (withDefault (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) "no"
343 >>> parseYesOrNo) -< tree
344 isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
345 >>> parseYesOrNo) -< tree
346 isBoring <- (withDefault (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText) "no"
347 >>> parseYesOrNo) -< tree
349 summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
351 >>> deleteIfEmpty)) -< tree
353 otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link"
355 (getAttrValue0 "lang"
357 getAttrValue0 "page")) -< tree
359 textData <- maybeA (getXPathTreesInDoc "/page/textData/text()" >>> getText) -< tree
360 binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
362 let (isBinary, content)
363 = case (textData, binaryData) of
364 (Just text, Nothing ) -> (False, L.pack $ encode text )
365 (Nothing , Just binary) -> (True , L.pack $ B64.decode binary)
366 _ -> error "one of textData or binaryData is required"
370 , entityType = mimeType
371 , entityLanguage = lang
372 , entityFileName = fileName
373 , entityIsTheme = isTheme
374 , entityIsFeed = isFeed
375 , entityIsLocked = isLocked
376 , entityIsBoring = isBoring
377 , entityIsBinary = isBinary
378 , entityRevision = undefined
379 , entityLastMod = undefined
380 , entitySummary = summary
381 , entityOtherLang = M.fromList otherLang
382 , entityContent = content
383 , entityUpdateInfo = updateInfo
387 parseUpdateInfo :: (ArrowXml a, ArrowChoice a) => a XmlTree UpdateInfo
390 -> do uInfo <- getXPathTreesInDoc "/*/updateInfo" -< tree
391 oldRev <- (getAttrValue0 "oldRevision" >>> arr read) -< uInfo
392 oldName <- maybeA (getXPathTrees "/move/@from/text()" >>> getText) -< uInfo
393 returnA -< UpdateInfo {
394 uiOldRevision = oldRev
395 , uiOldName = oldName