- -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
- BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
- StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
-
- name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
-
- let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
- scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
-
- pageTitle <- listA (readSubPage env) -< (name, Just page, "PageTitle")
- leftSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Left")
- rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right")
- pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
-
- ( eelem "/"
- += ( eelem "html"
- += sattr "xmlns" "http://www.w3.org/1999/xhtml"
- += ( getXPathTreesInDoc "/page/@lang"
- `guards`
- qattr (QN "xml" "lang" "")
- ( getXPathTreesInDoc "/page/@lang/text()" )
- )
- += ( eelem "head"
- += ( eelem "title"
- += txt siteName
- += txt " - "
- += getXPathTreesInDoc "/page/@name/text()"
- )
- += ( constL cssHref
- >>>
- eelem "link"
- += sattr "rel" "stylesheet"
- += sattr "type" "text/css"
- += attr "href" (arr id >>> mkText)
- )
- += ( constL scriptSrc
- >>>
- eelem "script"
- += sattr "type" "text/javascript"
- += attr "src" (arr id >>> mkText)
- )
- )
- += ( eelem "body"
- += ( eelem "div"
- += sattr "class" "header"
- )
- += ( eelem "div"
- += sattr "class" "center"
- += ( eelem "div"
- += sattr "class" "title"
- += constL pageTitle
- )
- += ( eelem "div"
- += sattr "class" "body"
- += constL pageBody
- )
- )
- += ( eelem "div"
- += sattr "class" "footer"
- )
- += ( eelem "div"
- += sattr "class" "left sideBar"
- += ( eelem "div"
- += sattr "class" "content"
- += constL leftSideBar
- )
- )
- += ( eelem "div"
- += sattr "class" "right sideBar"
- += ( eelem "div"
- += sattr "class" "content"
- += constL rightSideBar
- )
- )
- )
- ) ) -<< page
-
-
-readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
- Environment
- -> a (PageName, Maybe XmlTree, PageName) XmlTree
+ → do SiteName siteName ← getSysConfA (envSysConf env) ⤙ ()
+ BaseURI baseURI ← getSysConfA (envSysConf env) ⤙ ()
+ StyleSheet styleSheet ← getSysConfA (envSysConf env) ⤙ ()
+ GlobalLock isGLocked ← getSysConfA (envSysConf env) ⤙ ()
+
+ name ← (getXPathTreesInDoc "/page/@name/text()" ⋙ getText) ⤙ page
+ isLocked ← (getXPathTreesInDoc "/page/@isLocked/text()" ⋙ getText ⋙ parseYesOrNo) ⤙ page
+
+ let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
+ scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
+
+ pageTitle ← listA (readSubPage env) ⤙ (T.pack name, Just page, "PageTitle")
+ leftSideBar ← listA (readSubPage env) ⤙ (T.pack name, Just page, "SideBar/Left")
+ rightSideBar ← listA (readSubPage env) ⤙ (T.pack name, Just page, "SideBar/Right")
+ pageBody ← listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) ⤙ page
+
+ ( eelem "/"
+ += ( eelem "html"
+ += sattr "xmlns" "http://www.w3.org/1999/xhtml"
+ += ( getXPathTreesInDoc "/page/@lang"
+ `guards`
+ qattr (mkQName "xml" "lang" "")
+ ( getXPathTreesInDoc "/page/@lang/text()" )
+ )
+ += ( eelem "head"
+ += ( eelem "title"
+ += txt (T.unpack siteName)
+ += txt " - "
+ += getXPathTreesInDoc "/page/@name/text()"
+ )
+ += ( constL cssHref
+ ⋙
+ eelem "link"
+ += sattr "rel" "stylesheet"
+ += sattr "type" "text/css"
+ += attr "href" (arr id ⋙ mkText)
+ )
+ += mkFeedList env
+ += ( constL scriptSrc
+ ⋙
+ eelem "script"
+ += sattr "type" "text/javascript"
+ += attr "src" (arr id ⋙ mkText)
+ )
+ += ( eelem "script"
+ += sattr "type" "text/javascript"
+ += txt ("Rakka.baseURI=\"" ⊕ uriToString id baseURI "" ⊕ "\";")
+ += txt ("Rakka.isLocked=" ⊕ trueOrFalse isLocked ⊕ ";" )
+ += txt ("Rakka.isGlobalLocked=" ⊕ trueOrFalse isGLocked ⊕ ";" )
+ )
+ += mkGlobalJSList env
+ )
+ += ( eelem "body"
+ += ( eelem "div"
+ += sattr "class" "header"
+ )
+ += ( eelem "div"
+ += sattr "class" "center"
+ += ( eelem "div"
+ += sattr "class" "title"
+ += constL pageTitle
+ )
+ += ( eelem "div"
+ += sattr "class" "body"
+ += constL pageBody
+ )
+ )
+ += ( eelem "div"
+ += sattr "class" "footer"
+ )
+ += ( eelem "div"
+ += sattr "class" "left sideBar"
+ += ( eelem "div"
+ += sattr "class" "content"
+ += constL leftSideBar
+ )
+ )
+ += ( eelem "div"
+ += sattr "class" "right sideBar"
+ += ( eelem "div"
+ += sattr "class" "content"
+ += constL rightSideBar
+ )
+ )
+ )
+ ⋙
+ uniqueNamespacesFromDeclAndQNames
+ ) ) ⤛ page
+
+entityToRSS ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
+ ⇒ Environment
+ → XmlTree ⇝ XmlTree
+entityToRSS env
+ = proc page
+ → do SiteName siteName ← getSysConfA (envSysConf env) ⤙ ()
+ BaseURI baseURI ← getSysConfA (envSysConf env) ⤙ ()
+
+ name ← (getXPathTreesInDoc "/page/@name/text()" ⋙ getText) ⤙ page
+ summary ← maybeA (getXPathTreesInDoc "/page/summary/text()" ⋙ getText) ⤙ page
+ pages ← makePageLinkList (envStorage env) (envSysConf env) (envInterpTable env) ⤙ page
+
+ ( eelem "/"
+ += ( eelem "rdf:RDF"
+ += sattr "xmlns" "http://purl.org/rss/1.0/"
+ += sattr "xmlns:rdf" "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+ += sattr "xmlns:dc" "http://purl.org/dc/elements/1.1/"
+ += ( eelem "channel"
+ += sattr "rdf:about" (uriToString id (mkFeedURI baseURI (T.pack name)) "")
+ += ( eelem "title"
+ += txt (T.unpack siteName)
+ += txt " - "
+ += getXPathTreesInDoc "/page/@name/text()"
+ )
+ += ( eelem "link"
+ += txt (uriToString id baseURI "")
+ )
+ += ( eelem "description"
+ += txt (case summary of
+ Nothing → "RSS Feed for " ⊕ T.unpack siteName
+ Just s → s)
+ )
+ += ( eelem "items"
+ += ( eelem "rdf:Seq"
+ += ( constL pages
+ ⋙
+ eelem "rdf:li"
+ += attr "resource" (arr (mkPageURIStr baseURI) ⋙ mkText) ) ) ) )
+ += ( constL pages
+ ⋙
+ arr (\n → (n, Nothing))
+ ⋙
+ getPageA (envStorage env)
+ ⋙
+ arr fromJust
+ ⋙
+ eelem "item"
+ += attr "rdf:about" (arr (mkPageURIStr baseURI ∘ entityName) ⋙ mkText)
+ += ( eelem "title"
+ += (arr (T.unpack ∘ entityName) ⋙ mkText)
+ )
+ += ( eelem "link"
+ += (arr (mkPageURIStr baseURI ∘ entityName) ⋙ mkText)
+ )
+ += ( arrL (\p → case entitySummary p of
+ Nothing → []
+ Just s → [s])
+ ⋙
+ eelem "description"
+ += mkText
+ )
+ += ( eelem "dc:date"
+ += ( arrIO (utcToLocalZonedTime . entityLastMod)
+ ⋙
+ arr W3C.format
+ ⋙
+ mkText
+ )
+ )
+ )
+ ⋙
+ uniqueNamespacesFromDeclAndQNames
+ ) ) ⤛ page
+ where
+ mkPageURIStr :: URI → PageName → String
+ mkPageURIStr baseURI name
+ = uriToString id (mkPageURI baseURI name) ""
+
+readSubPage ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
+ ⇒ Environment
+ → (PageName, Maybe XmlTree, PageName) ⇝ XmlTree