The experiment has succeeded

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

diff --git a/Rakka/Resource/Render.hs b/Rakka/Resource/Render.hs
index df141b13ee2445db2df690fb8094ca54427c520a..599086b949b742c4b2df22b14d56d7f393178523 100644 (file)
--- a/Rakka/Resource/Render.hs
+++ b/Rakka/Resource/Render.hs
@@ -5,8 +5,10 @@ module Rakka.Resource.Render
 
 import           Control.Arrow
 import           Control.Arrow.ArrowIO
+import           Control.Arrow.ArrowIf
 import           Control.Arrow.ArrowList
 import           Data.Char
+import qualified Data.Map as M
 import           Network.HTTP.Lucu
 import           Network.HTTP.Lucu.Utils
 import           Network.URI
@@ -56,7 +58,7 @@ handleGet env name
             Just redir@(Redirection _ _ _ _)
                 -> handleRedirect env -< redir
 
-            Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _)
+            Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _)
                 -> handleGetEntity env -< entity
 
 {-
@@ -66,7 +68,7 @@ handleGet env name
 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
 handleRedirect env
     = proc redir
-    -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
+    -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
           returnA -< redirect Found (mkPageURI baseURI $ redirName redir) -- FIXME
 
 
@@ -75,6 +77,7 @@ handleRedirect env
         styleSheet="http://example.org/object/StyleSheet/Default"
         name="Foo/Bar"
         type="text/x-rakka"
+        lang="ja"           -- 存在しない場合もある
         isTheme="no"        -- text/css の場合のみ存在
         isFeed="no"         -- text/x-rakka の場合のみ存在
         isLocked="no"
@@ -110,9 +113,9 @@ handleRedirect env
 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
 handleGetEntity env
     = proc page
-    -> do SiteName   siteName <- getSysConfA sysConf (SiteName   undefined) -< ()
-          BaseURI    baseURI  <- getSysConfA sysConf (BaseURI    undefined) -< ()
-          StyleSheet cssName  <- getSysConfA sysConf (StyleSheet undefined) -< ()
+    -> do SiteName   siteName <- getSysConfA sysConf -< ()
+          BaseURI    baseURI  <- getSysConfA sysConf -< ()
+          StyleSheet cssName  <- getSysConfA sysConf -< ()
 
           Just pageTitle    <- getPageA (envStorage env) -< "PageTitle"
           Just leftSideBar  <- getPageA (envStorage env) -< "SideBar/Left"
@@ -124,6 +127,10 @@ handleGetEntity env
                          += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
                          += sattr "name"       (pageName page)
                          += sattr "type"       (show $ pageType page)
+                         += ( case pageLanguage page of
+                                Just x -> sattr "lang" x
+                                _      -> none
+                            )
                          += ( case pageType page of
                                 MIMEType "text" "css" _
                                     -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
@@ -146,29 +153,30 @@ handleGetEntity env
                                 Just s  -> eelem "summary" += txt s
                             )
 
-                         += ( case pageOtherLang page of
-                                [] -> none
-                                xs -> selem "otherLang"
-                                      [ eelem "link"
-                                        += sattr "lang" lang
-                                        += sattr "page" page
-                                            | (lang, page) <- xs ]
+                         += ( if M.null (pageOtherLang page) then
+                                  none
+                              else
+                                  selem "otherLang"
+                                            [ eelem "link"
+                                              += sattr "lang" lang
+                                              += sattr "page" page
+                                                  | (lang, page) <- M.toList (pageOtherLang page) ]
                             )
                          += ( eelem "pageTitle"
-                              += ( (constA (pageName page) &&& constA pageTitle)
+                              += ( (constA (pageName page) &&& constA (Just page) &&& constA pageTitle)
                                    >>>
                                    formatSubPage env
                                  )
                             )
                          += ( eelem "sideBar"
                               += ( eelem "left"
-                                   += ( (constA (pageName page) &&& constA leftSideBar)
+                                   += ( (constA (pageName page) &&& constA (Just page) &&& constA leftSideBar)
                                         >>>
                                         formatSubPage env
                                       )
                                  )
                               += ( eelem "right"
-                                   += ( (constA (pageName page) &&& constA rightSideBar)
+                                   += ( (constA (pageName page) &&& constA (Just page) &&& constA rightSideBar)
                                         >>>
                                         formatSubPage env
                                       )
@@ -205,6 +213,11 @@ entityToXHTML
     = 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"
                      += getXPathTreesInDoc "/page/@site/text()"
@@ -278,9 +291,9 @@ entityToXHTML
 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
 handlePageNotFound env
     = proc name
-    -> do SiteName   siteName <- getSysConfA sysConf (SiteName   undefined) -< ()
-          BaseURI    baseURI  <- getSysConfA sysConf (BaseURI    undefined) -< ()
-          StyleSheet cssName  <- getSysConfA sysConf (StyleSheet undefined) -< ()
+    -> do SiteName   siteName <- getSysConfA sysConf -< ()
+          BaseURI    baseURI  <- getSysConfA sysConf -< ()
+          StyleSheet cssName  <- getSysConfA sysConf -< ()
 
           Just pageTitle    <- getPageA (envStorage env) -< "PageTitle"
           Just leftSideBar  <- getPageA (envStorage env) -< "SideBar/Left"
@@ -293,20 +306,20 @@ handlePageNotFound env
                          += sattr "name"       name
                          
                          += ( eelem "pageTitle"
-                              += ( (constA name &&& constA pageTitle)
+                              += ( (constA name &&& constA Nothing &&& constA pageTitle)
                                    >>>
                                    formatSubPage env
                                  )
                             )
                          += ( eelem "sideBar"
                               += ( eelem "left"
-                                   += ( (constA name &&& constA leftSideBar)
+                                   += ( (constA name &&& constA Nothing &&& constA leftSideBar)
                                         >>>
                                         formatSubPage env
                                       )
                                  )
                               += ( eelem "right"
-                                   += ( (constA name &&& constA rightSideBar)
+                                   += ( (constA name &&& constA Nothing &&& constA rightSideBar)
                                         >>>
                                         formatSubPage env
                                       )