implemented page listing

[Rakka.git] / Rakka / Resource / PageEntity.hs

diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs
index dbef4d5b1a16615a26cd4271be67afe4084a270c..0b5459447419ffab669650e8f08f5bd1c6abe381 100644 (file)
--- a/Rakka/Resource/PageEntity.hs
+++ b/Rakka/Resource/PageEntity.hs
@@ -55,11 +55,16 @@ handleGet env name
     = runIdempotentA $ proc ()
     -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
           case pageM of
-            Nothing   -> handlePageNotFound env -< name
-            Just page -> if isEntity page then
-                             handleGetEntity env -< page
-                         else
-                             handleRedirect env -< page
+            Nothing
+                -> do items <- getDirContentsA (envStorage env) -< (name, Nothing)
+                      case items of
+                        [] -> handlePageNotFound   env -< name
+                        _  -> handleGetPageListing env -< (name, items)
+            Just page
+                -> if isEntity page then
+                       handleGetEntity env -< page
+                   else
+                       handleRedirect env -< page
 
 
 {-
@@ -213,6 +218,126 @@ readSubPage env
          returnA -< subXHTML
 
 
+{-
+  <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)
+
+
+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)
+                         )
+                      += ( 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 ++ ";")
+                         )
+                    )
+                 += ( 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
+
+
 {-
   <pageNotFound name="Foo/Bar" />
 -}