+ where
+ localize :: (ArrowChoice a, ArrowIO a) => Storage -> a (LanguageTag, Page) Page
+ localize sto
+ = proc (lang, origPage)
+ -> do let otherLang = entityOtherLang origPage
+ localName = M.lookup lang otherLang
+ case localName of
+ Nothing
+ -> returnA -< origPage
+ Just ln
+ -> do localPage <- getPageA sto -< (ln, Nothing)
+ returnA -< case localPage of
+ Nothing -> origPage
+ Just p -> p
+
+
+{-
+ <pageListing path="Foo">
+ <page name="Foo/Bar" />
+ <page name="Foo/Baz" />
+ </pageListing>
+-}
+handleGetPageListing :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a (PageName, [PageName]) (Resource ())
+handleGetPageListing env
+ = proc (dir, items)
+ -> do tree <- ( eelem "/"
+ += ( eelem "pageListing"
+ += attr "path" (arr fst >>> mkText)
+ += ( arrL snd
+ >>>
+ ( eelem "page"
+ += attr "name" (arr id >>> mkText)
+ )
+ )
+ )
+ ) -< (dir, items)
+ returnA -< outputXmlPage' tree (pageListingToXHTML env) -- FIXME: rss 對應
+
+
+pageListingToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
+pageListingToXHTML env
+ = proc pageListing
+ -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
+ BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
+ StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
+ GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
+
+ name <- (getXPathTreesInDoc "/pageListing/@path/text()" >>> getText) -< pageListing
+
+ let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
+ scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
+
+ pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
+ leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
+ rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
+
+ ( eelem "/"
+ += ( eelem "html"
+ += sattr "xmlns" "http://www.w3.org/1999/xhtml"
+ += ( eelem "head"
+ += ( eelem "title"
+ += txt siteName
+ += txt " - "
+ += getXPathTreesInDoc "/pageListing/@path/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.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"
+ += ( eelem "ul"
+ += ( getXPathTreesInDoc "/pageListing/page/@name/text()"
+ >>>
+ eelem "li"
+ += ( eelem "a"
+ += attr "href" ( getText
+ >>>
+ arr (\ x -> uriToString id (mkPageURI baseURI x) "")
+ >>>
+ mkText
+ )
+ += this
+ )
+ )
+ )
+ )
+ )
+ += ( 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
+ ) ) -<< pageListing