31 import qualified Codec.Binary.Base64 as B64
32 import qualified Codec.Binary.UTF8.String as UTF8
34 import Control.Arrow.ArrowIO
35 import Control.Arrow.ArrowList
36 import qualified Data.ByteString.Lazy as Lazy (ByteString)
37 import qualified Data.ByteString.Lazy as L hiding (ByteString)
40 import qualified Data.Map as M
43 import Network.HTTP.Lucu hiding (redirect)
44 import Network.URI hiding (fragment)
46 import Rakka.W3CDateTime
47 import Subversion.Types
48 import System.FilePath.Posix
49 import Text.XML.HXT.Arrow.XmlArrow
50 import Text.XML.HXT.Arrow.XmlNodeSet
51 import Text.XML.HXT.DOM.TypeDefs
54 type PageName = String
56 type LanguageTag = String -- See RFC 3066: http://www.ietf.org/rfc/rfc3066.txt
57 type LanguageName = String -- i.e. "日本語"
62 redirName :: !PageName
63 , redirDest :: !PageName
64 , redirIsLocked :: !Bool
65 , redirRevision :: RevNum
66 , redirLastMod :: UTCTime
67 , redirUpdateInfo :: Maybe UpdateInfo
70 entityName :: !PageName
71 , entityType :: !MIMEType
72 , entityLanguage :: !(Maybe LanguageTag)
73 , entityIsTheme :: !Bool -- text/css 以外では無意味
74 , entityIsFeed :: !Bool -- text/x-rakka 以外では無意味
75 , entityIsLocked :: !Bool
76 , entityIsBinary :: !Bool
77 , entityRevision :: RevNum
78 , entityLastMod :: UTCTime
79 , entitySummary :: !(Maybe String)
80 , entityOtherLang :: !(Map LanguageTag PageName)
81 , entityContent :: !Lazy.ByteString
82 , entityUpdateInfo :: Maybe UpdateInfo
89 uiOldRevision :: !RevNum
90 , uiOldName :: !(Maybe PageName)
95 isRedirect :: Page -> Bool
96 isRedirect (Redirection _ _ _ _ _ _) = True
100 isEntity :: Page -> Bool
101 isEntity (Entity _ _ _ _ _ _ _ _ _ _ _ _ _) = True
105 pageName :: Page -> PageName
107 | isRedirect p = redirName p
108 | isEntity p = entityName p
109 | otherwise = error "neither redirection nor entity"
112 pageUpdateInfo :: Page -> Maybe UpdateInfo
114 | isRedirect p = redirUpdateInfo p
115 | isEntity p = entityUpdateInfo p
116 | otherwise = error "neither redirection nor entity"
119 pageRevision :: Page -> RevNum
121 | isRedirect p = redirRevision p
122 | isEntity p = entityRevision p
123 | otherwise = error "neither redirection nor entity"
126 -- UTF-8 に encode してから 0x20 - 0x7E の範圍を除いて URI escape する。
127 encodePageName :: PageName -> FilePath
128 encodePageName = escapeURIString isSafeChar . UTF8.encodeString . fixPageName
130 fixPageName :: PageName -> PageName
131 fixPageName = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
134 isSafeChar :: Char -> Bool
137 | isReserved c = False
138 | c > ' ' && c <= '~' = True
142 -- URI unescape して UTF-8 から decode する。
143 decodePageName :: FilePath -> PageName
144 decodePageName = UTF8.decodeString . unEscapeString
147 encodeFragment :: String -> String
148 encodeFragment = escapeURIString isSafeChar . UTF8.encodeString
151 mkPageURI :: URI -> PageName -> URI
152 mkPageURI baseURI name
154 uriPath = "/" </> uriPath baseURI </> encodePageName name <.> "html"
158 mkPageFragmentURI :: URI -> PageName -> String -> URI
159 mkPageFragmentURI baseURI name fragment
161 uriPath = "/" </> uriPath baseURI </> encodePageName name <.> "html"
162 , uriFragment = ('#' : encodeFragment fragment)
166 mkFragmentURI :: String -> URI
167 mkFragmentURI fragment
169 uriFragment = ('#' : encodeFragment fragment)
173 mkObjectURI :: URI -> PageName -> URI
174 mkObjectURI baseURI name
175 = mkAuxiliaryURI baseURI ["object"] name
178 mkAuxiliaryURI :: URI -> [String] -> PageName -> URI
179 mkAuxiliaryURI baseURI basePath name
181 uriPath = foldl (</>) "/" ([uriPath baseURI] ++ basePath ++ [encodePageName name])
185 mkFeedURI :: URI -> PageName -> URI
186 mkFeedURI baseURI name
188 uriPath = "/" </> uriPath baseURI </> encodePageName name <.> "rdf"
192 mkRakkaURI :: PageName -> URI
193 mkRakkaURI name = URI {
195 , uriAuthority = Nothing
196 , uriPath = encodePageName name
205 lang="ja" -- 存在しない場合もある
206 isTheme="no" -- text/css の場合のみ存在
207 isFeed="no" -- text/x-rakka の場合のみ存在
211 lastModified="2000-01-01T00:00:00">
215 </summary> -- 存在しない場合もある
217 <otherLang> -- 存在しない場合もある
218 <link lang="ja" page="Bar/Baz" />
226 SKJaHKS8JK/DH8KS43JDK2aKKaSFLLS...
233 lastModified="2000-01-01T00:00:00" />
235 xmlizePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
238 -> if isRedirect page then
239 xmlizeRedirection -< page
243 xmlizeRedirection :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
246 -> do lastMod <- arrIO (utcToLocalZonedTime . redirLastMod) -< page
249 += sattr "name" (redirName page)
250 += sattr "redirect" (redirDest page)
251 += sattr "isLocked" (yesOrNo $ redirIsLocked page)
252 += sattr "revision" (show $ redirRevision page)
253 += sattr "lastModified" (formatW3CDateTime lastMod)
256 xmlizeEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
259 -> do lastMod <- arrIO (utcToLocalZonedTime . entityLastMod) -< page
262 += sattr "name" (pageName page)
263 += sattr "type" (show $ entityType page)
264 += ( case entityLanguage page of
265 Just x -> sattr "lang" x
268 += ( case entityType page of
269 MIMEType "text" "css" _
270 -> sattr "isTheme" (yesOrNo $ entityIsTheme page)
271 MIMEType "text" "x-rakka" _
272 -> sattr "isFeed" (yesOrNo $ entityIsFeed page)
276 += sattr "isLocked" (yesOrNo $ entityIsLocked page)
277 += sattr "isBinary" (yesOrNo $ entityIsBinary page)
278 += sattr "revision" (show $ entityRevision page)
279 += sattr "lastModified" (formatW3CDateTime lastMod)
280 += ( case entitySummary page of
281 Just s -> eelem "summary" += txt s
284 += ( if M.null (entityOtherLang page) then
291 | (lang, name) <- M.toList (entityOtherLang page) ]
293 += ( if entityIsBinary page then
295 += txt (B64.encode $ L.unpack $ entityContent page)
299 += txt (UTF8.decode $ L.unpack $ entityContent page)
305 parseXmlizedPage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
308 -> do updateInfo <- maybeA parseUpdateInfo -< tree
309 redirect <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
310 isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
311 >>> parseYesOrNo) -< tree
313 Nothing -> parseEntity -< (name, tree)
314 Just dest -> returnA -< (Redirection {
317 , redirIsLocked = isLocked
318 , redirRevision = undefined
319 , redirLastMod = undefined
320 , redirUpdateInfo = updateInfo
324 parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
327 -> do updateInfo <- maybeA parseUpdateInfo -< tree
329 mimeTypeStr <- withDefault (getXPathTreesInDoc "/page/@type/text()" >>> getText) "" -< tree
331 lang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree
333 isTheme <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no"
334 >>> parseYesOrNo) -< tree
335 isFeed <- (withDefault (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) "no"
336 >>> parseYesOrNo) -< tree
337 isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
338 >>> parseYesOrNo) -< tree
340 summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
342 >>> deleteIfEmpty)) -< tree
344 otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link"
346 (getAttrValue0 "lang"
348 getAttrValue0 "page")) -< tree
350 textData <- maybeA (getXPathTreesInDoc "/page/textData/text()" >>> getText) -< tree
351 binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
353 let (isBinary, content)
354 = case (textData, binaryData) of
355 (Just text, Nothing ) -> (False, L.pack $ UTF8.encode text )
356 (Nothing , Just binary) -> (True , L.pack $ fromJust $ B64.decode $ dropWhitespace binary)
357 _ -> error "one of textData or binaryData is required"
360 if null mimeTypeStr then
361 guessMIMEType content
369 , entityType = mimeType
370 , entityLanguage = lang
371 , entityIsTheme = isTheme
372 , entityIsFeed = isFeed
373 , entityIsLocked = isLocked
374 , entityIsBinary = isBinary
375 , entityRevision = undefined
376 , entityLastMod = undefined
377 , entitySummary = summary
378 , entityOtherLang = M.fromList otherLang
379 , entityContent = content
380 , entityUpdateInfo = updateInfo
383 dropWhitespace :: String -> String
384 dropWhitespace [] = []
385 dropWhitespace (x:xs)
386 | x == ' ' || x == '\t' || x == '\n'
389 = x : dropWhitespace xs
392 parseUpdateInfo :: (ArrowXml a, ArrowChoice a) => a XmlTree UpdateInfo
395 -> do uInfo <- getXPathTreesInDoc "/page/updateInfo" -< tree
396 oldRev <- (getAttrValue0 "oldRevision" >>> arr read) -< uInfo
397 oldName <- maybeA (getXPathTrees "/updateInfo/move/@from/text()" >>> getText) -< uInfo
398 returnA -< UpdateInfo {
399 uiOldRevision = oldRev
400 , uiOldName = oldName