]> gitweb @ CieloNegro.org - Rakka.git/blob - Rakka/Resource/PageEntity.hs
c805ae5fe9af0ec4f44152c8a7e2278523ecb7a8
[Rakka.git] / Rakka / Resource / PageEntity.hs
1 module Rakka.Resource.PageEntity
2     ( fallbackPageEntity
3     )
4     where
5 import           Control.Monad.Trans
6 import qualified Data.ByteString.Lazy as L hiding (ByteString)
7 import           Data.Char
8 import qualified Data.Map as M
9 import           Data.Maybe
10 import           Data.Time
11 import qualified Data.Time.W3C as W3C
12 import           Network.HTTP.Lucu
13 import           Network.URI hiding (path)
14 import           Rakka.Environment
15 import           Rakka.Page
16 import           Rakka.Resource
17 import           Rakka.Storage
18 import           Rakka.SystemConfig
19 import           Rakka.Utils
20 import           Rakka.Wiki.Engine
21 import           System.FilePath.Posix
22 import           Text.HyperEstraier hiding (getText)
23 import           Text.XML.HXT.XPath
24
25
26 fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef)
27 fallbackPageEntity env path
28     | null name           = return Nothing
29     | isLower $ head name = return Nothing -- 先頭の文字が小文字であってはならない
30     | otherwise
31         = return $ Just $ ResourceDef {
32             resUsesNativeThread = False
33           , resIsGreedy         = True
34           , resGet              = Just $ handleGet    env name
35           , resHead             = Nothing
36           , resPost             = Nothing
37           , resPut              = Just $ handlePut    env name
38           , resDelete           = Just $ handleDelete env name
39           }
40     where
41       name :: PageName
42       name = (dropExtension . UTF8.decodeString . joinPath) path
43
44
45 handleGet :: Environment -> PageName -> Resource ()
46 handleGet env name
47     = do BaseURI baseURI <- getSysConf (envSysConf env)
48          runIdempotentA baseURI $ proc ()
49              -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
50                    case pageM of
51                      Nothing
52                          -> do items <- getDirContentsA (envStorage env) -< (name, Nothing)
53                                case items of
54                                  [] -> handlePageNotFound   env -< name
55                                  _  -> handleGetPageListing env -< (name, items)
56                      Just page
57                          -> if isEntity page then
58                                 handleGetEntity env -< page
59                             else
60                                 handleRedirect env -< page
61
62
63 {-
64   HTTP/1.1 302 Found
65   Location: http://example.org/Destination.html#Redirect:Source
66 -}
67 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
68 handleRedirect env
69     = proc redir
70     -> returnA -< do mType <- getEntityType
71                      case mType of
72                        MIMEType "text" "xml" _
73                            -> do setContentType mType
74                                  [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
75                                                                 >>>
76                                                                 constA redir
77                                                                 >>>
78                                                                 xmlizePage
79                                                                 >>>
80                                                                 writeDocumentToString [ (a_indent         , v_1 )
81                                                                                       , (a_output_encoding, utf8)
82                                                                                       , (a_no_xml_pi      , v_0 ) ]
83                                                               )
84                                  output resultStr
85
86                        _   -> do BaseURI baseURI <- getSysConf (envSysConf env)
87                                  let uri = mkPageFragmentURI
88                                            baseURI
89                                            (redirDest redir)
90                                            ("Redirect:" ++ redirName redir)
91                                  redirect Found uri
92
93
94 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
95 handleGetEntity env
96     = proc page
97     -> do tree <- xmlizePage -< page
98           returnA -< outputXmlPage tree [ (MIMEType "application" "xhtml+xml" [], entityToXHTML env)
99                                         , (MIMEType "application" "rss+xml"   [], entityToRSS   env)
100                                         ]
101
102
103 entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
104 entityToXHTML env
105     = proc page
106     -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
107           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
108           StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
109           GlobalLock isGLocked  <- getSysConfA (envSysConf env) -< ()
110
111           name     <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
112           isLocked <- (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText >>> parseYesOrNo) -< page
113
114           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
115               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
116
117           pageTitle    <- listA (readSubPage env) -< (name, Just page, "PageTitle")
118           leftSideBar  <- listA (readSubPage env) -< (name, Just page, "SideBar/Left")
119           rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right")
120           pageBody     <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
121
122           ( eelem "/"
123             += ( eelem "html"
124                  += sattr "xmlns" "http://www.w3.org/1999/xhtml"
125                  += ( getXPathTreesInDoc "/page/@lang"
126                       `guards`
127                       qattr (mkQName "xml" "lang" "")
128                                 ( getXPathTreesInDoc "/page/@lang/text()" )
129                     )
130                  += ( eelem "head"
131                       += ( eelem "title"
132                            += txt siteName
133                            += txt " - "
134                            += getXPathTreesInDoc "/page/@name/text()"
135                          )
136                       += ( constL cssHref
137                            >>>
138                            eelem "link"
139                            += sattr "rel"  "stylesheet"
140                            += sattr "type" "text/css"
141                            += attr "href" (arr id >>> mkText)
142                          )
143                       += mkFeedList env
144                       += ( constL scriptSrc
145                            >>>
146                            eelem "script"
147                            += sattr "type" "text/javascript"
148                            += attr "src" (arr id >>> mkText)
149                          )
150                       += ( eelem "script"
151                            += sattr "type" "text/javascript"
152                            += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
153                            += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";")
154                            += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
155                          )
156                       += mkGlobalJSList env
157                     )
158                  += ( eelem "body"
159                       += ( eelem "div"
160                            += sattr "class" "header"
161                          )
162                       += ( eelem "div"
163                            += sattr "class" "center"
164                            += ( eelem "div"
165                                 += sattr "class" "title"
166                                 += constL pageTitle
167                               )
168                            += ( eelem "div"
169                                 += sattr "class" "body"
170                                 += constL pageBody
171                               )
172                          )
173                       += ( eelem "div"
174                            += sattr "class" "footer"
175                          )
176                       += ( eelem "div"
177                            += sattr "class" "left sideBar"
178                            += ( eelem "div"
179                                 += sattr "class" "content"
180                                 += constL leftSideBar
181                               )
182                          )
183                       += ( eelem "div"
184                            += sattr "class" "right sideBar"
185                            += ( eelem "div"
186                                 += sattr "class" "content"
187                                 += constL rightSideBar
188                               )
189                          )
190                     )
191                  >>>
192                  uniqueNamespacesFromDeclAndQNames
193                ) ) -<< page
194
195
196 entityToRSS :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
197 entityToRSS env
198     = proc page
199     -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
200           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
201
202           name    <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
203           summary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< page
204           pages   <- makePageLinkList (envStorage env) (envSysConf env) (envInterpTable env) -< page
205           
206           ( eelem "/"
207             += ( eelem "rdf:RDF"
208                  += sattr "xmlns"           "http://purl.org/rss/1.0/"
209                  += sattr "xmlns:rdf"       "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
210                  += sattr "xmlns:dc"        "http://purl.org/dc/elements/1.1/"
211                  += sattr "xmlns:trackback" "http://madskills.com/public/xml/rss/module/trackback/"
212                  += ( eelem "channel"
213                       += sattr "rdf:about" (uriToString id (mkFeedURI baseURI name) "")
214                       += ( eelem "title"
215                            += txt siteName
216                            += txt " - "
217                            += getXPathTreesInDoc "/page/@name/text()"
218                          )
219                       += ( eelem "link"
220                            += txt (uriToString id baseURI "")
221                          )
222                       += ( eelem "description"
223                            += txt (case summary of
224                                      Nothing -> "RSS Feed for " ++ siteName
225                                      Just s  -> s)
226                          )
227                       += ( eelem "items"
228                            += ( eelem "rdf:Seq"
229                                 += ( constL pages
230                                      >>>
231                                      eelem "rdf:li"
232                                      += attr "resource" (arr (mkPageURIStr baseURI) >>> mkText)
233                                    )
234                               )
235                          )
236                     )
237                  += ( constL pages
238                       >>>
239                       arr (\ n -> (n, Nothing))
240                       >>>
241                       getPageA (envStorage env)
242                       >>>
243                       arr fromJust
244                       >>>
245                       eelem "item"
246                       += attr "rdf:about" (arr (mkPageURIStr baseURI . entityName) >>> mkText)
247                       += ( eelem "title"
248                            += (arr entityName >>> mkText)
249                          )
250                       += ( eelem "link"
251                            += (arr (mkPageURIStr baseURI . entityName) >>> mkText)
252                          )
253                       += ( arrL (\ p -> case entitySummary p of
254                                           Nothing -> []
255                                           Just s  -> [s])
256                            >>>
257                            eelem "description"
258                            += mkText
259                          )
260                       += ( eelem "dc:date"
261                            += ( arrIO (utcToLocalZonedTime . entityLastMod)
262                                 >>>
263                                 arr W3C.format
264                                 >>>
265                                 mkText
266                               )
267                          )
268                       += ( eelem "trackback:ping"
269                            += attr "rdf:resource" (arr (mkTrackbackURIStr baseURI . entityName) >>> mkText)
270                          )
271                     )
272                  >>>
273                  uniqueNamespacesFromDeclAndQNames
274                ) ) -<< page
275     where
276       mkPageURIStr :: URI -> PageName -> String
277       mkPageURIStr baseURI name
278             = uriToString id (mkPageURI baseURI name) ""
279
280       mkTrackbackURIStr :: URI -> PageName -> String
281       mkTrackbackURIStr baseURI name
282             = uriToString id (mkAuxiliaryURI baseURI ["trackback"] name) ""
283
284
285 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
286                Environment
287             -> a (PageName, Maybe XmlTree, PageName) XmlTree
288 readSubPage env
289     = proc (mainPageName, mainPage, subPageName) ->
290       do langM        <- case mainPage of
291                            Nothing
292                                -> returnA -< Nothing
293                            Just p
294                                -> maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< p
295          subPage      <- getPageA (envStorage env) >>> arr fromJust -< (subPageName, Nothing)
296          localSubPage <- case langM of
297                            Nothing
298                                -> returnA -< subPage
299                            Just l
300                                -> localize (envStorage env) -< (l, subPage)
301          subPageXml   <- xmlizePage -< localSubPage
302          subXHTML     <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
303                          -< (Just mainPageName, mainPage, subPageXml)
304          returnA -< subXHTML
305     where
306       localize :: (ArrowChoice a, ArrowIO a) => Storage -> a (LanguageTag, Page) Page
307       localize sto
308           = proc (lang, origPage)
309           -> do let otherLang = entityOtherLang origPage
310                     localName = M.lookup lang otherLang
311                 case localName of
312                   Nothing
313                       -> returnA -< origPage
314                   Just ln
315                       -> do localPage <- getPageA sto -< (ln, Nothing)
316                             returnA -< case localPage of
317                                          Nothing -> origPage
318                                          Just p  -> p
319
320
321 {-
322   <pageListing path="Foo">
323     <page name="Foo/Bar" />
324     <page name="Foo/Baz" />
325   </pageListing>
326 -}
327 handleGetPageListing :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a (PageName, [PageName]) (Resource ())
328 handleGetPageListing env
329     = proc (dir, items)
330     -> do tree <- ( eelem "/"
331                     += ( eelem "pageListing"
332                          += attr "path" (arr fst >>> mkText)
333                          += ( arrL snd
334                               >>> 
335                               ( eelem "page"
336                                 += attr "name" (arr id >>> mkText)
337                               )
338                             )
339                        )
340                   ) -< (dir, items)
341           returnA -< outputXmlPage' tree (pageListingToXHTML env) -- FIXME: rss 對應
342
343
344 pageListingToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
345 pageListingToXHTML env
346     = proc pageListing
347     -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
348           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
349           StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
350           GlobalLock isGLocked  <- getSysConfA (envSysConf env) -< ()
351
352           name <- (getXPathTreesInDoc "/pageListing/@path/text()" >>> getText) -< pageListing
353
354           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
355               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
356
357           pageTitle    <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
358           leftSideBar  <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
359           rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
360
361           ( eelem "/"
362             += ( eelem "html"
363                  += sattr "xmlns" "http://www.w3.org/1999/xhtml"
364                  += ( eelem "head"
365                       += ( eelem "title"
366                            += txt siteName
367                            += txt " - "
368                            += getXPathTreesInDoc "/pageListing/@path/text()"
369                          )
370                       += ( constL cssHref
371                            >>>
372                            eelem "link"
373                            += sattr "rel"  "stylesheet"
374                            += sattr "type" "text/css"
375                            += attr "href" (arr id >>> mkText)
376                          )
377                       += mkFeedList env
378                       += ( constL scriptSrc
379                            >>>
380                            eelem "script"
381                            += sattr "type" "text/javascript"
382                            += attr "src" (arr id >>> mkText)
383                          )
384                       += ( eelem "script"
385                            += sattr "type" "text/javascript"
386                            += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
387                            += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
388                          )
389                       += mkGlobalJSList env
390                     )
391                  += ( eelem "body"
392                       += ( eelem "div"
393                            += sattr "class" "header"
394                          )
395                       += ( eelem "div"
396                            += sattr "class" "center"
397                            += ( eelem "div"
398                                 += sattr "class" "title"
399                                 += constL pageTitle
400                               )
401                            += ( eelem "div"
402                                 += sattr "class" "body"
403                                 += ( eelem "ul"
404                                      += ( getXPathTreesInDoc "/pageListing/page/@name/text()"
405                                           >>>
406                                           eelem "li"
407                                           += ( eelem "a"
408                                                += attr "href" ( getText
409                                                                 >>>
410                                                                 arr (\ x -> uriToString id (mkPageURI baseURI x) "")
411                                                                 >>>
412                                                                 mkText
413                                                               )
414                                                += this
415                                              )
416                                         )
417                                    )
418                               )
419                          )
420                       += ( eelem "div"
421                            += sattr "class" "footer"
422                          )
423                       += ( eelem "div"
424                            += sattr "class" "left sideBar"
425                            += ( eelem "div"
426                                 += sattr "class" "content"
427                                 += constL leftSideBar
428                               )
429                          )
430                       += ( eelem "div"
431                            += sattr "class" "right sideBar"
432                            += ( eelem "div"
433                                 += sattr "class" "content"
434                                 += constL rightSideBar
435                               )
436                          )
437                     )
438                  >>>
439                  uniqueNamespacesFromDeclAndQNames
440                ) ) -<< pageListing
441
442
443 {-
444   <pageNotFound name="Foo/Bar" />
445 -}
446 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
447 handlePageNotFound env
448     = proc name
449     -> do tree <- ( eelem "/"
450                     += ( eelem "pageNotFound"
451                          += attr "name" (arr id >>> mkText)
452                        )
453                   ) -< name
454           returnA -< do setStatus NotFound
455                         outputXmlPage' tree (notFoundToXHTML env)
456
457
458 notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
459 notFoundToXHTML env
460     = proc pageNotFound
461     -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
462           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
463           StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
464           GlobalLock isGLocked  <- getSysConfA (envSysConf env) -< ()
465
466           name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
467
468           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
469               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
470
471           pageTitle    <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
472           leftSideBar  <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
473           rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
474
475           ( eelem "/"
476             += ( eelem "html"
477                  += sattr "xmlns" "http://www.w3.org/1999/xhtml"
478                  += ( eelem "head"
479                       += ( eelem "title"
480                            += txt siteName
481                            += txt " - "
482                            += getXPathTreesInDoc "/pageNotFound/@name/text()"
483                          )
484                       += ( constL cssHref
485                            >>>
486                            eelem "link"
487                            += sattr "rel"  "stylesheet"
488                            += sattr "type" "text/css"
489                            += attr "href" (arr id >>> mkText)
490                          )
491                       += mkFeedList env
492                       += ( constL scriptSrc
493                            >>>
494                            eelem "script"
495                            += sattr "type" "text/javascript"
496                            += attr "src" (arr id >>> mkText)
497                          )
498                       += ( eelem "script"
499                            += sattr "type" "text/javascript"
500                            += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
501                            += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
502                          )
503                       += mkGlobalJSList env
504                     )
505                  += ( eelem "body"
506                       += ( eelem "div"
507                            += sattr "class" "header"
508                          )
509                       += ( eelem "div"
510                            += sattr "class" "center"
511                            += ( eelem "div"
512                                 += sattr "class" "title"
513                                 += constL pageTitle
514                               )
515                            += ( eelem "div"
516                                 += sattr "class" "body"
517                                 += txt "404 Not Found (FIXME)" -- FIXME
518                               )
519                          )
520                       += ( eelem "div"
521                            += sattr "class" "footer"
522                          )
523                       += ( eelem "div"
524                            += sattr "class" "left sideBar"
525                            += ( eelem "div"
526                                 += sattr "class" "content"
527                                 += constL leftSideBar
528                               )
529                          )
530                       += ( eelem "div"
531                            += sattr "class" "right sideBar"
532                            += ( eelem "div"
533                                 += sattr "class" "content"
534                                 += constL rightSideBar
535                               )
536                          )
537                     )
538                  >>>
539                  uniqueNamespacesFromDeclAndQNames
540                ) ) -<< pageNotFound
541
542
543 handlePut :: Environment -> PageName -> Resource ()
544 handlePut env name
545     = do userID <- getUserID env
546          runXmlA env "rakka-page-1.0.rng" $ proc tree
547              -> do page   <- parseXmlizedPage -< (name, tree)
548                    status <- putPageA (envStorage env) -< (userID, page)
549                    returnA  -< setStatus status
550
551
552 handleDelete :: Environment -> PageName -> Resource ()
553 handleDelete env name
554     = do userID <- getUserID env
555          status <- deletePage (envStorage env) userID name
556          setStatus status
557
558
559 mkFeedList :: (ArrowIO a, ArrowXml a) => Environment -> a b XmlTree
560 mkFeedList env
561     = proc _ -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
562                    BaseURI  baseURI  <- getSysConfA (envSysConf env) -< ()
563
564                    feed <- unlistA <<< arrIO0 (findFeeds $ envStorage env) -< ()
565                    
566                    ( eelem "link"
567                      += sattr "rel"   "alternate"
568                      += sattr "type"  "application/rss+xml"
569                      += attr  "title" (txt siteName <+> txt " - " <+> mkText)
570                      += attr  "href"  (arr (mkFeedURIStr baseURI) >>> mkText) ) -<< feed
571
572
573 findFeeds :: Storage -> IO [PageName]
574 findFeeds sto
575     = do cond <- newCondition
576          setPhrase   cond "[UVSET]"
577          addAttrCond cond "rakka:isFeed STREQ yes"
578          setOrder    cond "@uri STRA"
579          result <- searchPages sto cond
580          return (map hpPageName $ srPages result)
581
582
583 mkGlobalJSList :: (ArrowIO a, ArrowXml a, ArrowChoice a) => Environment -> a b XmlTree
584 mkGlobalJSList env
585     = proc _ -> do BaseURI baseURI  <- getSysConfA (envSysConf env) -< ()
586
587                    scriptName <- unlistA <<< arrIO0 (findJavaScripts $ envStorage env) -< ()
588                    pageM      <- getPageA (envStorage env) -< (scriptName, Nothing)
589
590                    case pageM of
591                      Nothing -> none -< ()
592                      Just page
593                          | isEntity page
594                              -> ( if entityIsBinary page then
595                                       ( eelem "script"
596                                         += sattr "type" "text/javascript"
597                                         += attr "src" (arr (mkObjectURIStr baseURI . pageName) >>> mkText) )
598                                   else
599                                       ( eelem "script"
600                                         += sattr "type" "text/javascript"
601                                         += (arr (UTF8.decode . L.unpack . entityContent) >>> mkText) )
602                                 ) -<< page
603                          | otherwise
604                              -> none -< ()
605
606
607 findJavaScripts :: Storage -> IO [PageName]
608 findJavaScripts sto
609     = do cond <- newCondition
610          setPhrase   cond "[UVSET]"
611          addAttrCond cond "@title STRBW Global/"
612          addAttrCond cond "@type  STRBW text/javascript"
613          setOrder    cond "@uri STRA"
614          result <- searchPages sto cond
615          return (map hpPageName $ srPages result)
616
617
618 mkFeedURIStr :: URI -> PageName -> String
619 mkFeedURIStr baseURI name
620     = uriToString id (mkFeedURI baseURI name) ""
621
622
623 mkObjectURIStr :: URI -> PageName -> String
624 mkObjectURIStr baseURI name
625     = uriToString id (mkObjectURI baseURI name) ""