33 import qualified Codec.Binary.Base64 as B64
34 import Codec.Binary.UTF8.String
36 import Control.Arrow.ArrowIO
37 import Control.Arrow.ArrowList
38 import qualified Data.ByteString.Lazy as Lazy (ByteString)
39 import qualified Data.ByteString.Lazy as L hiding (ByteString)
42 import qualified Data.Map as M
45 import Network.HTTP.Lucu hiding (redirect)
46 import Network.URI hiding (fragment)
48 import Rakka.W3CDateTime
49 import Subversion.Types
50 import System.FilePath.Posix
51 import Text.XML.HXT.Arrow.XmlArrow
52 import Text.XML.HXT.Arrow.XmlNodeSet
53 import Text.XML.HXT.DOM.TypeDefs
56 type PageName = String
58 type LanguageTag = String -- See RFC 3066: http://www.ietf.org/rfc/rfc3066.txt
59 type LanguageName = String -- i.e. "日本語"
64 redirName :: !PageName
65 , redirDest :: !PageName
66 , redirRevision :: RevNum
67 , redirLastMod :: UTCTime
68 , redirUpdateInfo :: Maybe UpdateInfo
71 entityName :: !PageName
72 , entityType :: !MIMEType
73 , entityLanguage :: !(Maybe LanguageTag)
74 , entityFileName :: !(Maybe String)
75 , entityIsTheme :: !Bool -- text/css 以外では無意味
76 , entityIsFeed :: !Bool -- text/x-rakka 以外では無意味
77 , entityIsLocked :: !Bool
78 , entityIsBoring :: !Bool
79 , entityIsBinary :: !Bool
80 , entityRevision :: RevNum
81 , entityLastMod :: UTCTime
82 , entitySummary :: !(Maybe String)
83 , entityOtherLang :: !(Map LanguageTag PageName)
84 , entityContent :: !Lazy.ByteString
85 , entityUpdateInfo :: Maybe UpdateInfo
92 uiOldRevision :: !RevNum
93 , uiOldName :: !(Maybe PageName)
98 isRedirect :: Page -> Bool
99 isRedirect (Redirection _ _ _ _ _) = True
103 isEntity :: Page -> Bool
104 isEntity (Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) = True
108 pageName :: Page -> PageName
110 | isRedirect p = redirName p
111 | isEntity p = entityName p
112 | otherwise = error "neither redirection nor entity"
115 pageUpdateInfo :: Page -> Maybe UpdateInfo
117 | isRedirect p = redirUpdateInfo p
118 | isEntity p = entityUpdateInfo p
119 | otherwise = error "neither redirection nor entity"
122 pageRevision :: Page -> RevNum
124 | isRedirect p = redirRevision p
125 | isEntity p = entityRevision p
126 | otherwise = error "neither redirection nor entity"
129 -- UTF-8 に encode してから 0x20 - 0x7E の範圍を除いて URI escape する。
130 encodePageName :: PageName -> FilePath
131 encodePageName = escapeURIString isSafeChar . encodeString . fixPageName
133 fixPageName :: PageName -> PageName
134 fixPageName = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
137 isSafeChar :: Char -> Bool
140 | isReserved c = False
141 | c > ' ' && c <= '~' = True
145 -- URI unescape して UTF-8 から decode する。
146 decodePageName :: FilePath -> PageName
147 decodePageName = decodeString . unEscapeString
150 encodeFragment :: String -> String
151 encodeFragment = escapeURIString isSafeChar . encodeString
154 entityFileName' :: Page -> String
156 = fromMaybe (defaultFileName (entityType page) (entityName page)) (entityFileName page)
159 defaultFileName :: MIMEType -> PageName -> String
160 defaultFileName pType pName
161 = let baseName = takeFileName pName
164 MIMEType "text" "x-rakka" _ -> baseName <.> "rakka"
165 MIMEType "text" "css" _ -> baseName <.> "css"
169 mkPageURI :: URI -> PageName -> URI
170 mkPageURI baseURI name
172 uriPath = foldl (</>) "/" [uriPath baseURI, encodePageName name ++ ".html"]
176 mkPageFragmentURI :: URI -> PageName -> String -> URI
177 mkPageFragmentURI baseURI name fragment
179 uriPath = foldl (</>) "/" [uriPath baseURI, encodePageName name ++ ".html"]
180 , uriFragment = ('#' : encodeFragment fragment)
184 mkFragmentURI :: String -> URI
185 mkFragmentURI fragment
187 uriFragment = ('#' : encodeFragment fragment)
191 mkObjectURI :: URI -> PageName -> URI
192 mkObjectURI baseURI name
193 = mkAuxiliaryURI baseURI ["object"] name
196 mkAuxiliaryURI :: URI -> [String] -> PageName -> URI
197 mkAuxiliaryURI baseURI basePath name
199 uriPath = foldl (</>) "/" ([uriPath baseURI] ++ basePath ++ [encodePageName name])
203 mkRakkaURI :: PageName -> URI
204 mkRakkaURI name = URI {
206 , uriAuthority = Nothing
207 , uriPath = encodePageName name
216 lang="ja" -- 存在しない場合もある
217 fileName="bar.rakka" -- 存在しない場合もある
218 isTheme="no" -- text/css の場合のみ存在
219 isFeed="no" -- text/x-rakka の場合のみ存在
223 lastModified="2000-01-01T00:00:00">
227 </summary> -- 存在しない場合もある
229 <otherLang> -- 存在しない場合もある
230 <link lang="ja" page="Bar/Baz" />
238 SKJaHKS8JK/DH8KS43JDK2aKKaSFLLS...
245 lastModified="2000-01-01T00:00:00" />
247 xmlizePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
250 -> if isRedirect page then
251 xmlizeRedirection -< page
255 xmlizeRedirection :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
258 -> do lastMod <- arrIO (utcToLocalZonedTime . redirLastMod) -< page
261 += sattr "name" (redirName page)
262 += sattr "redirect" (redirDest page)
263 += sattr "revision" (show $ redirRevision page)
264 += sattr "lastModified" (formatW3CDateTime lastMod)
267 xmlizeEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
270 -> do lastMod <- arrIO (utcToLocalZonedTime . entityLastMod) -< page
273 += sattr "name" (pageName page)
274 += sattr "type" (show $ entityType page)
275 += ( case entityLanguage page of
276 Just x -> sattr "lang" x
279 += ( case entityFileName page of
280 Just x -> sattr "fileName" x
283 += ( case entityType page of
284 MIMEType "text" "css" _
285 -> sattr "isTheme" (yesOrNo $ entityIsTheme page)
286 MIMEType "text" "x-rakka" _
287 -> sattr "isFeed" (yesOrNo $ entityIsFeed page)
291 += sattr "isLocked" (yesOrNo $ entityIsLocked page)
292 += sattr "isBoring" (yesOrNo $ entityIsBoring page)
293 += sattr "isBinary" (yesOrNo $ entityIsBinary page)
294 += sattr "revision" (show $ entityRevision page)
295 += sattr "lastModified" (formatW3CDateTime lastMod)
296 += ( case entitySummary page of
297 Just s -> eelem "summary" += txt s
300 += ( if M.null (entityOtherLang page) then
307 | (lang, name) <- M.toList (entityOtherLang page) ]
309 += ( if entityIsBinary page then
311 += txt (B64.encode $ L.unpack $ entityContent page)
315 += txt (decode $ L.unpack $ entityContent page)
321 parseXmlizedPage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
324 -> do updateInfo <- maybeA parseUpdateInfo -< tree
325 redirect <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
327 Nothing -> parseEntity -< (name, tree)
328 Just dest -> returnA -< (Redirection {
331 , redirRevision = undefined
332 , redirLastMod = undefined
333 , redirUpdateInfo = updateInfo
337 parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
340 -> do updateInfo <- maybeA parseUpdateInfo -< tree
342 mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText
343 >>> arr read) -< tree
345 lang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree
346 fileName <- maybeA (getXPathTreesInDoc "/page/@filename/text()" >>> getText) -< tree
348 isTheme <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no"
349 >>> parseYesOrNo) -< tree
350 isFeed <- (withDefault (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) "no"
351 >>> parseYesOrNo) -< tree
352 isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
353 >>> parseYesOrNo) -< tree
354 isBoring <- (withDefault (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText) "no"
355 >>> parseYesOrNo) -< tree
357 summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
359 >>> deleteIfEmpty)) -< tree
361 otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link"
363 (getAttrValue0 "lang"
365 getAttrValue0 "page")) -< tree
367 textData <- maybeA (getXPathTreesInDoc "/page/textData/text()" >>> getText) -< tree
368 binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
370 let (isBinary, content)
371 = case (textData, binaryData) of
372 (Just text, Nothing ) -> (False, L.pack $ encode text )
373 (Nothing , Just binary) -> (True , L.pack $ B64.decode binary)
374 _ -> error "one of textData or binaryData is required"
378 , entityType = mimeType
379 , entityLanguage = lang
380 , entityFileName = fileName
381 , entityIsTheme = isTheme
382 , entityIsFeed = isFeed
383 , entityIsLocked = isLocked
384 , entityIsBoring = isBoring
385 , entityIsBinary = isBinary
386 , entityRevision = undefined
387 , entityLastMod = undefined
388 , entitySummary = summary
389 , entityOtherLang = M.fromList otherLang
390 , entityContent = content
391 , entityUpdateInfo = updateInfo
395 parseUpdateInfo :: (ArrowXml a, ArrowChoice a) => a XmlTree UpdateInfo
398 -> do uInfo <- getXPathTreesInDoc "/*/updateInfo" -< tree
399 oldRev <- (getAttrValue0 "oldRevision" >>> arr read) -< uInfo
400 oldName <- maybeA (getXPathTrees "/move/@from/text()" >>> getText) -< uInfo
401 returnA -< UpdateInfo {
402 uiOldRevision = oldRev
403 , uiOldName = oldName