]> gitweb @ CieloNegro.org - Rakka.git/blob - Rakka/Page.hs
c1d72119e348c1f7ca02dadd980cd1e440912f1c
[Rakka.git] / Rakka / Page.hs
1 module Rakka.Page
2     ( PageName
3     , Page(..)
4     , UpdateInfo(..)
5     , LanguageTag
6     , LanguageName
7
8     , isRedirect
9     , isEntity
10
11     , pageName
12     , pageUpdateInfo
13     , pageRevision
14
15     , encodePageName
16     , decodePageName
17
18     , mkPageURI
19     , mkPageFragmentURI
20     , mkObjectURI
21     , mkFragmentURI
22     , mkAuxiliaryURI
23     , mkRakkaURI
24
25     , xmlizePage
26     , parseXmlizedPage
27     )
28     where
29
30 import qualified Codec.Binary.Base64 as B64
31 import qualified Codec.Binary.UTF8.String as UTF8
32 import           Control.Arrow
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)
37 import           Data.Char
38 import           Data.Map (Map)
39 import qualified Data.Map as M
40 import           Data.Maybe
41 import           Data.Time
42 import           Network.HTTP.Lucu hiding (redirect)
43 import           Network.URI hiding (fragment)
44 import           Rakka.Utils
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
51
52
53 type PageName = String
54
55 type LanguageTag  = String -- See RFC 3066: http://www.ietf.org/rfc/rfc3066.txt
56 type LanguageName = String -- i.e. "日本語"
57
58
59 data Page
60     = Redirection {
61         redirName       :: !PageName
62       , redirDest       :: !PageName
63       , redirRevision   :: RevNum
64       , redirLastMod    :: UTCTime
65       , redirUpdateInfo :: Maybe UpdateInfo
66       }
67     | Entity {
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       , entityIsBoring   :: !Bool
75       , entityIsBinary   :: !Bool
76       , entityRevision   :: RevNum
77       , entityLastMod    :: UTCTime
78       , entitySummary    :: !(Maybe String)
79       , entityOtherLang  :: !(Map LanguageTag PageName)
80       , entityContent    :: !Lazy.ByteString
81       , entityUpdateInfo :: Maybe UpdateInfo
82       }
83     deriving (Show, Eq)
84
85
86 data UpdateInfo
87     = UpdateInfo {
88         uiOldRevision :: !RevNum
89       , uiOldName     :: !(Maybe PageName)
90       }
91     deriving (Show, Eq)
92
93
94 isRedirect :: Page -> Bool
95 isRedirect (Redirection _ _ _ _ _) = True
96 isRedirect _                       = False
97
98
99 isEntity :: Page -> Bool
100 isEntity (Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _) = True
101 isEntity _                                    = False
102
103
104 pageName :: Page -> PageName
105 pageName p
106     | isRedirect p = redirName p
107     | isEntity   p = entityName p
108     | otherwise    = error "neither redirection nor entity"
109
110
111 pageUpdateInfo :: Page -> Maybe UpdateInfo
112 pageUpdateInfo p
113     | isRedirect p = redirUpdateInfo p
114     | isEntity   p = entityUpdateInfo p
115     | otherwise    = error "neither redirection nor entity"
116
117
118 pageRevision :: Page -> RevNum
119 pageRevision p
120     | isRedirect p = redirRevision p
121     | isEntity   p = entityRevision p
122     | otherwise    = error "neither redirection nor entity"
123
124
125 -- UTF-8 に encode してから 0x20 - 0x7E の範圍を除いて URI escape する。
126 encodePageName :: PageName -> FilePath
127 encodePageName = escapeURIString isSafeChar . UTF8.encodeString . fixPageName
128     where
129       fixPageName :: PageName -> PageName
130       fixPageName = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
131
132
133 isSafeChar :: Char -> Bool
134 isSafeChar c
135     | c == '/'            = True
136     | isReserved c        = False
137     | c > ' ' && c <= '~' = True
138     | otherwise           = False
139
140
141 -- URI unescape して UTF-8 から decode する。
142 decodePageName :: FilePath -> PageName
143 decodePageName = UTF8.decodeString . unEscapeString
144
145
146 encodeFragment :: String -> String
147 encodeFragment = escapeURIString isSafeChar . UTF8.encodeString
148
149
150 mkPageURI :: URI -> PageName -> URI
151 mkPageURI baseURI name
152     = baseURI {
153         uriPath = foldl (</>) "/" [uriPath baseURI, encodePageName name ++ ".html"]
154       }
155
156
157 mkPageFragmentURI :: URI -> PageName -> String -> URI
158 mkPageFragmentURI baseURI name fragment
159     = baseURI {
160         uriPath     = foldl (</>) "/" [uriPath baseURI, encodePageName name ++ ".html"]
161       , uriFragment = ('#' : encodeFragment fragment)
162       }
163
164
165 mkFragmentURI :: String -> URI
166 mkFragmentURI fragment
167     = nullURI {
168         uriFragment = ('#' : encodeFragment fragment)
169       }
170
171
172 mkObjectURI :: URI -> PageName -> URI
173 mkObjectURI baseURI name
174     = mkAuxiliaryURI baseURI ["object"] name
175
176
177 mkAuxiliaryURI :: URI -> [String] -> PageName -> URI
178 mkAuxiliaryURI baseURI basePath name
179     = baseURI {
180         uriPath = foldl (</>) "/" ([uriPath baseURI] ++ basePath ++ [encodePageName name])
181       }
182
183
184 mkRakkaURI :: PageName -> URI
185 mkRakkaURI name = URI {
186                     uriScheme    = "rakka:"
187                   , uriAuthority = Nothing
188                   , uriPath      = encodePageName name
189                   , uriQuery     = ""
190                   , uriFragment  = ""
191                   }
192
193
194 {-
195   <page name="Foo/Bar"
196         type="text/x-rakka"
197         lang="ja"            -- 存在しない場合もある
198         isTheme="no"         -- text/css の場合のみ存在
199         isFeed="no"          -- text/x-rakka の場合のみ存在
200         isLocked="no"
201         isBinary="no"
202         revision="112"
203         lastModified="2000-01-01T00:00:00">
204
205     <summary>
206         blah blah...
207     </summary> -- 存在しない場合もある
208
209     <otherLang> -- 存在しない場合もある
210       <link lang="ja" page="Bar/Baz" />
211     </otherLang>
212
213     <!-- 何れか一方のみ -->
214     <textData>
215       blah blah...
216     </textData>
217     <binaryData>
218       SKJaHKS8JK/DH8KS43JDK2aKKaSFLLS...
219     </binaryData>
220   </page>
221
222   <page name="Foo/Bar"
223         redirect="Baz"
224         revision="112"
225         lastModified="2000-01-01T00:00:00" />
226 -}
227 xmlizePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
228 xmlizePage 
229     = proc page
230     -> if isRedirect page then
231            xmlizeRedirection -< page
232        else
233            xmlizeEntity -< page
234     where
235       xmlizeRedirection :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
236       xmlizeRedirection 
237           = proc page
238           -> do lastMod <- arrIO (utcToLocalZonedTime . redirLastMod) -< page
239                 ( eelem "/"
240                   += ( eelem "page"
241                        += sattr "name"     (redirName page)
242                        += sattr "redirect" (redirDest page)
243                        += sattr "revision" (show $ redirRevision page)
244                        += sattr "lastModified" (formatW3CDateTime lastMod)
245                      )) -<< ()
246
247       xmlizeEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
248       xmlizeEntity 
249           = proc page
250           -> do lastMod <- arrIO (utcToLocalZonedTime . entityLastMod) -< page
251                 ( eelem "/"
252                   += ( eelem "page"
253                        += sattr "name" (pageName page)
254                        += sattr "type" (show $ entityType page)
255                        += ( case entityLanguage page of
256                               Just x  -> sattr "lang" x
257                               Nothing -> none
258                           )
259                        += ( case entityType page of
260                               MIMEType "text" "css" _
261                                   -> sattr "isTheme" (yesOrNo $ entityIsTheme page)
262                               MIMEType "text" "x-rakka" _
263                                   -> sattr "isFeed"  (yesOrNo $ entityIsFeed page)
264                               _
265                                   -> none
266                           )
267                        += sattr "isLocked" (yesOrNo $ entityIsLocked page)
268                        += sattr "isBoring" (yesOrNo $ entityIsBoring page)
269                        += sattr "isBinary" (yesOrNo $ entityIsBinary page)
270                        += sattr "revision" (show $ entityRevision page)
271                        += sattr "lastModified" (formatW3CDateTime lastMod)
272                        += ( case entitySummary page of
273                               Just s  -> eelem "summary" += txt s
274                               Nothing -> none
275                           )
276                        += ( if M.null (entityOtherLang page) then
277                                 none
278                             else
279                                 selem "otherLang"
280                                           [ eelem "link"
281                                             += sattr "lang" lang
282                                             += sattr "page" name
283                                                 | (lang, name) <- M.toList (entityOtherLang page) ]
284                           )
285                        += ( if entityIsBinary page then
286                                 ( eelem "binaryData"
287                                   += txt (B64.encode $ L.unpack $ entityContent page)
288                                 )
289                             else
290                                 ( eelem "textData"
291                                   += txt (UTF8.decode $ L.unpack $ entityContent page)
292                                 )
293                           )
294                      )) -<< ()
295
296
297 parseXmlizedPage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
298 parseXmlizedPage 
299     = proc (name, tree)
300     -> do updateInfo <- maybeA parseUpdateInfo -< tree
301           redirect   <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
302           case redirect of
303             Nothing   -> parseEntity -< (name, tree)
304             Just dest -> returnA     -< (Redirection {
305                                            redirName       = name
306                                          , redirDest       = dest
307                                          , redirRevision   = undefined
308                                          , redirLastMod    = undefined
309                                          , redirUpdateInfo = updateInfo
310                                          })
311             
312
313 parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
314 parseEntity
315     = proc (name, tree)
316     -> do updateInfo <- maybeA parseUpdateInfo -< tree
317
318           mimeTypeStr <- withDefault (getXPathTreesInDoc "/page/@type/text()" >>> getText) "" -< tree
319
320           lang     <- maybeA (getXPathTreesInDoc "/page/@lang/text()"     >>> getText) -< tree
321
322           isTheme  <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no"
323                        >>> parseYesOrNo) -< tree
324           isFeed   <- (withDefault (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) "no"
325                        >>> parseYesOrNo) -< tree
326           isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
327                        >>> parseYesOrNo) -< tree
328           isBoring <- (withDefault (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText) "no"
329                        >>> parseYesOrNo) -< tree
330
331           summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
332                               >>> getText
333                               >>> deleteIfEmpty)) -< tree
334                       
335           otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link"
336                               >>>
337                               (getAttrValue0 "lang"
338                                &&&
339                                getAttrValue0 "page")) -< tree
340
341           textData   <- maybeA (getXPathTreesInDoc "/page/textData/text()"   >>> getText) -< tree
342           binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
343
344           let (isBinary, content)
345                   = case (textData, binaryData) of
346                       (Just text, Nothing    ) -> (False, L.pack $ UTF8.encode text )
347                       (Nothing  , Just binary) -> (True , L.pack $ B64.decode binary)
348                       _                        -> error "one of textData or binaryData is required"
349               mimeType
350                   =  if isBinary then
351                          if null mimeTypeStr then
352                              guessMIMEType content
353                          else
354                              read mimeTypeStr
355                      else
356                          read mimeTypeStr
357
358           returnA -< Entity {
359                         entityName       = name
360                       , entityType       = mimeType
361                       , entityLanguage   = lang
362                       , entityIsTheme    = isTheme
363                       , entityIsFeed     = isFeed
364                       , entityIsLocked   = isLocked
365                       , entityIsBoring   = isBoring
366                       , entityIsBinary   = isBinary
367                       , entityRevision   = undefined
368                       , entityLastMod    = undefined
369                       , entitySummary    = summary
370                       , entityOtherLang  = M.fromList otherLang
371                       , entityContent    = content
372                       , entityUpdateInfo = updateInfo
373                       }
374
375
376 parseUpdateInfo :: (ArrowXml a, ArrowChoice a) => a XmlTree UpdateInfo
377 parseUpdateInfo 
378     = proc tree
379     -> do uInfo   <- getXPathTreesInDoc "/page/updateInfo" -< tree
380           oldRev  <- (getAttrValue0 "oldRevision" >>> arr read) -< uInfo
381           oldName <- maybeA (getXPathTrees "/updateInfo/move/@from/text()" >>> getText) -< uInfo
382           returnA -< UpdateInfo {
383                         uiOldRevision = oldRev
384                       , uiOldName     = oldName
385                       }
386
387