7 module Rakka.Resource.PageEntity
11 import Control.Applicative
13 import Control.Arrow.ArrowIO
14 import Control.Arrow.ArrowIf
15 import Control.Arrow.ArrowList
16 import Control.Arrow.Unicode
17 import qualified Codec.Binary.UTF8.String as UTF8
18 import Control.Monad.Trans
19 import qualified Data.ByteString.Lazy as L hiding (ByteString)
20 import qualified Data.CaseInsensitive as CI
22 import qualified Data.Map as M
24 import Data.Monoid.Unicode
25 import qualified Data.Text as T
27 import qualified Data.Time.W3C as W3C
28 import Network.HTTP.Lucu
29 import Network.URI hiding (path)
30 import Prelude.Unicode
31 import Rakka.Environment
35 import Rakka.SystemConfig
37 import Rakka.Wiki.Engine
38 import System.FilePath.Posix
39 import Text.HyperEstraier hiding (getText)
40 import Text.XML.HXT.Arrow.Namespace
41 import Text.XML.HXT.Arrow.WriteDocument
42 import Text.XML.HXT.Arrow.XmlArrow
43 import Text.XML.HXT.Arrow.XmlState
44 import Text.XML.HXT.DOM.TypeDefs
45 import Text.XML.HXT.XPath
47 fallbackPageEntity ∷ Environment → [String] → IO (Maybe ResourceDef)
48 fallbackPageEntity env path
49 | T.null name = return Nothing
50 | isLower $ T.head name = return Nothing -- 先頭の文字が小文字であってはならない
52 = pure $ Just ResourceDef {
53 resUsesNativeThread = False
55 , resGet = Just $ handleGet env name
58 , resPut = Just $ handlePut env name
59 , resDelete = Just $ handleDelete env name
63 name = T.pack ∘ dropExtension ∘ UTF8.decodeString $ joinPath path
65 handleGet :: Environment -> PageName -> Resource ()
67 = do BaseURI baseURI <- getSysConf (envSysConf env)
68 runIdempotentA baseURI $ proc ()
69 -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
72 -> do items <- getDirContentsA (envStorage env) -< (name, Nothing)
74 [] -> handlePageNotFound env -< name
75 _ -> handleGetPageListing env -< (name, items)
77 -> if isEntity page then
78 handleGetEntity env -< page
80 handleRedirect env -< page
84 Location: http://example.org/Destination.html#Redirect:Source
86 handleRedirect ∷ (ArrowXml (⇝), ArrowIO (⇝)) ⇒ Environment → Page ⇝ Resource ()
89 → returnA ⤙ do mType ← getEntityType
91 MIMEType "text" "xml" _
92 → do setContentType mType
93 [resultStr] ← liftIO $
94 runX ( setErrorMsgHandler False fail
100 writeDocumentToString
105 output $ UTF8.encodeString resultStr
106 _ → do BaseURI baseURI ← getSysConf (envSysConf env)
107 let uri = mkPageFragmentURI
110 ("Redirect:" ⊕ redirName redir)
113 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
116 -> do tree <- xmlizePage -< page
117 returnA -< outputXmlPage tree [ (MIMEType "application" "xhtml+xml" [], entityToXHTML env)
118 , (MIMEType "application" "rss+xml" [], entityToRSS env)
122 entityToXHTML ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
127 → do SiteName siteName ← getSysConfA (envSysConf env) ⤙ ()
128 BaseURI baseURI ← getSysConfA (envSysConf env) ⤙ ()
129 StyleSheet styleSheet ← getSysConfA (envSysConf env) ⤙ ()
130 GlobalLock isGLocked ← getSysConfA (envSysConf env) ⤙ ()
132 name ← (getXPathTreesInDoc "/page/@name/text()" ⋙ getText) ⤙ page
133 isLocked ← (getXPathTreesInDoc "/page/@isLocked/text()" ⋙ getText ⋙ parseYesOrNo) ⤙ page
135 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
136 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
138 pageTitle ← listA (readSubPage env) ⤙ (T.pack name, Just page, "PageTitle")
139 leftSideBar ← listA (readSubPage env) ⤙ (T.pack name, Just page, "SideBar/Left")
140 rightSideBar ← listA (readSubPage env) ⤙ (T.pack name, Just page, "SideBar/Right")
141 pageBody ← listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) ⤙ page
145 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
146 += ( getXPathTreesInDoc "/page/@lang"
148 qattr (mkQName "xml" "lang" "")
149 ( getXPathTreesInDoc "/page/@lang/text()" )
153 += txt (T.unpack siteName)
155 += getXPathTreesInDoc "/page/@name/text()"
160 += sattr "rel" "stylesheet"
161 += sattr "type" "text/css"
162 += attr "href" (arr id ⋙ mkText)
165 += ( constL scriptSrc
168 += sattr "type" "text/javascript"
169 += attr "src" (arr id ⋙ mkText)
172 += sattr "type" "text/javascript"
173 += txt ("Rakka.baseURI=\"" ⊕ uriToString id baseURI "" ⊕ "\";")
174 += txt ("Rakka.isLocked=" ⊕ trueOrFalse isLocked ⊕ ";" )
175 += txt ("Rakka.isGlobalLocked=" ⊕ trueOrFalse isGLocked ⊕ ";" )
177 += mkGlobalJSList env
181 += sattr "class" "header"
184 += sattr "class" "center"
186 += sattr "class" "title"
190 += sattr "class" "body"
195 += sattr "class" "footer"
198 += sattr "class" "left sideBar"
200 += sattr "class" "content"
201 += constL leftSideBar
205 += sattr "class" "right sideBar"
207 += sattr "class" "content"
208 += constL rightSideBar
213 uniqueNamespacesFromDeclAndQNames
216 entityToRSS ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
221 → do SiteName siteName ← getSysConfA (envSysConf env) ⤙ ()
222 BaseURI baseURI ← getSysConfA (envSysConf env) ⤙ ()
224 name ← (getXPathTreesInDoc "/page/@name/text()" ⋙ getText) ⤙ page
225 summary ← maybeA (getXPathTreesInDoc "/page/summary/text()" ⋙ getText) ⤙ page
226 pages ← makePageLinkList (envStorage env) (envSysConf env) (envInterpTable env) ⤙ page
230 += sattr "xmlns" "http://purl.org/rss/1.0/"
231 += sattr "xmlns:rdf" "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
232 += sattr "xmlns:dc" "http://purl.org/dc/elements/1.1/"
234 += sattr "rdf:about" (uriToString id (mkFeedURI baseURI (T.pack name)) "")
236 += txt (T.unpack siteName)
238 += getXPathTreesInDoc "/page/@name/text()"
241 += txt (uriToString id baseURI "")
243 += ( eelem "description"
244 += txt (case summary of
245 Nothing → "RSS Feed for " ⊕ T.unpack siteName
253 += attr "resource" (arr (mkPageURIStr baseURI) ⋙ mkText) ) ) ) )
256 arr (\n → (n, Nothing))
258 getPageA (envStorage env)
263 += attr "rdf:about" (arr (mkPageURIStr baseURI ∘ entityName) ⋙ mkText)
265 += (arr (T.unpack ∘ entityName) ⋙ mkText)
268 += (arr (mkPageURIStr baseURI ∘ entityName) ⋙ mkText)
270 += ( arrL (\p → case entitySummary p of
278 += ( arrIO (utcToLocalZonedTime . entityLastMod)
287 uniqueNamespacesFromDeclAndQNames
290 mkPageURIStr :: URI → PageName → String
291 mkPageURIStr baseURI name
292 = uriToString id (mkPageURI baseURI name) ""
294 readSubPage ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
296 → (PageName, Maybe XmlTree, PageName) ⇝ XmlTree
298 = proc (mainPageName, mainPage, subPageName) →
299 do langM ← case mainPage of
303 → maybeA (getXPathTreesInDoc "/page/@lang/text()" ⋙ getText) ⤙ p
304 subPage ← getPageA (envStorage env) ⋙ arr fromJust ⤙ (subPageName, Nothing)
305 localSubPage ← case langM of
309 → localize (envStorage env) ⤙ (CI.mk $ T.pack l, subPage)
310 subPageXml ← xmlizePage ⤙ localSubPage
311 subXHTML ← makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
312 ⤙ (Just mainPageName, mainPage, subPageXml)
315 localize ∷ (ArrowChoice (⇝), ArrowIO (⇝)) ⇒ Storage → (LanguageTag, Page) ⇝ Page
317 = proc (lang, origPage)
318 → do let otherLang = entityOtherLang origPage
319 localName = M.lookup lang otherLang
324 → do localPage ← getPageA sto ⤙ (ln, Nothing)
325 returnA ⤙ case localPage of
331 <pageListing path="Foo">
332 <page name="Foo/Bar" />
333 <page name="Foo/Baz" />
336 handleGetPageListing ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
338 → (PageName, [PageName]) ⇝ Resource ()
339 handleGetPageListing env
341 → do tree ← ( eelem "/"
342 += ( eelem "pageListing"
343 += attr "path" (arr (T.unpack ∘ fst) ⋙ mkText)
347 += attr "name" (arr (T.unpack ∘ id) ⋙ mkText)
352 returnA ⤙ outputXmlPage' tree (pageListingToXHTML env) -- FIXME: rss 對應
354 pageListingToXHTML ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
357 pageListingToXHTML env
359 → do SiteName siteName ← getSysConfA (envSysConf env) ⤙ ()
360 BaseURI baseURI ← getSysConfA (envSysConf env) ⤙ ()
361 StyleSheet styleSheet ← getSysConfA (envSysConf env) ⤙ ()
362 GlobalLock isGLocked ← getSysConfA (envSysConf env) ⤙ ()
364 name ← (getXPathTreesInDoc "/pageListing/@path/text()" ⋙ getText) ⤙ pageListing
366 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
367 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
369 pageTitle ← listA (readSubPage env) ⤙ (T.pack name, Nothing, "PageTitle")
370 leftSideBar ← listA (readSubPage env) ⤙ (T.pack name, Nothing, "SideBar/Left")
371 rightSideBar ← listA (readSubPage env) ⤙ (T.pack name, Nothing, "SideBar/Right")
375 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
378 += txt (T.unpack siteName)
380 += getXPathTreesInDoc "/pageListing/@path/text()"
385 += sattr "rel" "stylesheet"
386 += sattr "type" "text/css"
387 += attr "href" (arr id ⋙ mkText)
390 += ( constL scriptSrc
393 += sattr "type" "text/javascript"
394 += attr "src" (arr id ⋙ mkText)
397 += sattr "type" "text/javascript"
398 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
399 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
401 += mkGlobalJSList env
405 += sattr "class" "header"
408 += sattr "class" "center"
410 += sattr "class" "title"
414 += sattr "class" "body"
416 += ( getXPathTreesInDoc "/pageListing/page/@name/text()"
420 += attr "href" ( getText
422 arr (\ x → uriToString id (mkPageURI baseURI (T.pack x)) "")
429 += sattr "class" "footer"
432 += sattr "class" "left sideBar"
434 += sattr "class" "content"
435 += constL leftSideBar
439 += sattr "class" "right sideBar"
441 += sattr "class" "content"
442 += constL rightSideBar
447 uniqueNamespacesFromDeclAndQNames
451 <pageNotFound name="Foo/Bar" />
453 handlePageNotFound ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
455 → PageName ⇝ Resource ()
456 handlePageNotFound env
458 → do tree ← ( eelem "/"
459 += ( eelem "pageNotFound"
460 += attr "name" (arr T.unpack ⋙ mkText)
463 returnA ⤙ do setStatus NotFound
464 outputXmlPage' tree (notFoundToXHTML env)
466 notFoundToXHTML ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
471 → do SiteName siteName ← getSysConfA (envSysConf env) ⤙ ()
472 BaseURI baseURI ← getSysConfA (envSysConf env) ⤙ ()
473 StyleSheet styleSheet ← getSysConfA (envSysConf env) ⤙ ()
474 GlobalLock isGLocked ← getSysConfA (envSysConf env) ⤙ ()
476 name ← (getXPathTreesInDoc "/pageNotFound/@name/text()" ⋙ getText) ⤙ pageNotFound
478 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
479 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
481 pageTitle ← listA (readSubPage env) ⤙ (T.pack name, Nothing, "PageTitle" )
482 leftSideBar ← listA (readSubPage env) ⤙ (T.pack name, Nothing, "SideBar/Left" )
483 rightSideBar ← listA (readSubPage env) ⤙ (T.pack name, Nothing, "SideBar/Right")
487 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
490 += txt (T.unpack siteName)
492 += getXPathTreesInDoc "/pageNotFound/@name/text()"
497 += sattr "rel" "stylesheet"
498 += sattr "type" "text/css"
499 += attr "href" (arr id ⋙ mkText)
502 += ( constL scriptSrc
505 += sattr "type" "text/javascript"
506 += attr "src" (arr id ⋙ mkText)
509 += sattr "type" "text/javascript"
510 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
511 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
513 += mkGlobalJSList env
517 += sattr "class" "header"
520 += sattr "class" "center"
522 += sattr "class" "title"
526 += sattr "class" "body"
527 += txt "404 Not Found (FIXME)" -- FIXME
531 += sattr "class" "footer"
534 += sattr "class" "left sideBar"
536 += sattr "class" "content"
537 += constL leftSideBar
541 += sattr "class" "right sideBar"
543 += sattr "class" "content"
544 += constL rightSideBar
549 uniqueNamespacesFromDeclAndQNames
552 handlePut ∷ Environment → PageName → Resource ()
554 = do userID ← getUserID env
555 runXmlA "rakka-page-1.0.rng" $ proc tree
556 → do page ← parseXmlizedPage ⤙ (name, tree)
557 status ← putPageA (envStorage env) ⤙ (userID, page)
558 returnA ⤙ setStatus status
560 handleDelete ∷ Environment → PageName → Resource ()
561 handleDelete env name
562 = do userID ← getUserID env
563 status ← deletePage (envStorage env) userID name
566 mkFeedList ∷ (ArrowIO (⇝), ArrowXml (⇝)) ⇒ Environment → β ⇝ XmlTree
569 → do SiteName siteName ← getSysConfA (envSysConf env) ⤙ ()
570 BaseURI baseURI ← getSysConfA (envSysConf env) ⤙ ()
571 feed ← unlistA ⋘ arrIO0 (findFeeds $ envStorage env) ⤙ ()
573 += sattr "rel" "alternate"
574 += sattr "type" "application/rss+xml"
575 += attr "title" (txt (T.unpack siteName) <+> txt " - " <+> (arr T.unpack ⋙ mkText))
576 += attr "href" (arr (mkFeedURIStr baseURI) ⋙ mkText) ) ⤛ feed
578 findFeeds :: Storage -> IO [PageName]
580 = do cond <- newCondition
581 setPhrase cond "[UVSET]"
582 addAttrCond cond "rakka:isFeed STREQ yes"
583 setOrder cond "@uri STRA"
584 result <- searchPages sto cond
585 return (map hpPageName $ srPages result)
588 mkGlobalJSList :: (ArrowIO a, ArrowXml a, ArrowChoice a) => Environment -> a b XmlTree
590 = proc _ -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
592 scriptName <- unlistA <<< arrIO0 (findJavaScripts $ envStorage env) -< ()
593 pageM <- getPageA (envStorage env) -< (scriptName, Nothing)
596 Nothing -> none -< ()
599 -> ( if entityIsBinary page then
601 += sattr "type" "text/javascript"
602 += attr "src" (arr (mkObjectURIStr baseURI . pageName) >>> mkText) )
605 += sattr "type" "text/javascript"
606 += (arr (UTF8.decode . L.unpack . entityContent) >>> mkText) )
611 findJavaScripts ∷ Storage → IO [PageName]
613 = do cond ← newCondition
614 setPhrase cond "[UVSET]"
615 addAttrCond cond "@title STRBW Global/"
616 addAttrCond cond "@type STRBW text/javascript"
617 setOrder cond "@uri STRA"
618 result ← searchPages sto cond
619 return (map hpPageName $ srPages result)
621 mkFeedURIStr ∷ URI → PageName → String
622 mkFeedURIStr = flip flip "" ∘ (uriToString id ∘) ∘ mkFeedURI
624 mkObjectURIStr ∷ URI → PageName → String
625 mkObjectURIStr = flip flip "" ∘ (uriToString id ∘) ∘ mkObjectURI