From: pho <pho@cielonegro.org>
Date: Mon, 11 Feb 2008 03:18:27 +0000 (+0900)
Subject: GET /systemConfig HTTP/1.0
X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=commitdiff_plain;h=522dde5470584bb3f82cb0b4179233724d2408d0

GET /systemConfig HTTP/1.0

darcs-hash:20080211031827-62b54-fe852f337b169810583b75400f48a036d22dbb35.gz
---

diff --git a/Main.hs b/Main.hs
index 1e670c8..81f41a5 100644
--- a/Main.hs
+++ b/Main.hs
@@ -12,6 +12,7 @@ import           Rakka.Resource.PageEntity
 import           Rakka.Resource.Object
 import           Rakka.Resource.Render
 import           Rakka.Resource.Search
+import           Rakka.Resource.SystemConfig
 import           Rakka.Resource.TrackBack
 import           Rakka.Storage
 import           Subversion
@@ -139,15 +140,16 @@ main = withSubversion $
           
 resTree :: Environment -> ResTree
 resTree env
-    = mkResTree [ ([]             , resIndex     env)
-                , (["checkAuth"  ], resCheckAuth env)
-                , (["js"         ], javaScript      )
-                , (["object"     ], resObject    env)
-                , (["render"     ], resRender    env)
-                , (["search"     ], resSearch    env)
-                , (["search.html"], resSearch    env)
-                , (["search.xml" ], resSearch    env)
-                , (["trackback"  ], resTrackBack env)
+    = mkResTree [ ([]              , resIndex        env)
+                , (["checkAuth"   ], resCheckAuth    env)
+                , (["js"          ], javaScript         )
+                , (["object"      ], resObject       env)
+                , (["render"      ], resRender       env)
+                , (["search"      ], resSearch       env)
+                , (["search.html" ], resSearch       env)
+                , (["search.xml"  ], resSearch       env)
+                , (["systemConfig"], resSystemConfig env)
+                , (["trackback"   ], resTrackBack    env)
                 ]
 
 
diff --git a/Rakka.cabal b/Rakka.cabal
index d9f9b0a..2be97be 100644
--- a/Rakka.cabal
+++ b/Rakka.cabal
@@ -73,6 +73,7 @@ Executable rakka
         Rakka.Resource.PageEntity
         Rakka.Resource.Render
         Rakka.Resource.Search
+        Rakka.Resource.SystemConfig
         Rakka.Resource.TrackBack
         Rakka.Storage
         Rakka.Storage.DefaultPage
diff --git a/Rakka/Resource/SystemConfig.hs b/Rakka/Resource/SystemConfig.hs
new file mode 100644
index 0000000..110ecc1
--- /dev/null
+++ b/Rakka/Resource/SystemConfig.hs
@@ -0,0 +1,93 @@
+module Rakka.Resource.SystemConfig
+    ( resSystemConfig
+    )
+    where
+
+import           Control.Arrow
+import           Control.Arrow.ArrowIO
+import           Control.Monad.Trans
+import           Network.HTTP.Lucu
+import           Rakka.Environment
+import           Rakka.SystemConfig
+import           Text.XML.HXT.Arrow.WriteDocument
+import           Text.XML.HXT.Arrow.XmlArrow
+import           Text.XML.HXT.Arrow.XmlIOStateArrow
+import           Text.XML.HXT.DOM.TypeDefs
+import           Text.XML.HXT.DOM.XmlKeywords
+
+
+resSystemConfig :: Environment -> ResourceDef
+resSystemConfig env
+    = ResourceDef {
+        resUsesNativeThread = False
+      , resIsGreedy         = False
+      , resGet              = Just $ handleGet env
+      , resHead             = Nothing
+      , resPost             = Nothing
+      , resPut              = Just $ handlePut env
+      , resDelete           = Nothing
+      }
+
+
+{-
+  <systemConfig>
+    <value path="siteName">Rakka</value>
+    <value path="defaultPage">MainPage</value>
+  </systemConfig>
+-}
+handleGet :: Environment -> Resource ()
+handleGet env
+    = do setContentType $ read "text/xml"
+         [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
+                                     >>>
+                                     mkSystemConfigTree env
+                                     >>>
+                                     writeDocumentToString [ (a_indent, v_1) ]
+                                   )
+         output xmlStr
+
+
+mkSystemConfigTree :: (ArrowXml a, ArrowIO a) => Environment -> a b XmlTree
+mkSystemConfigTree env
+    = let sc = envSysConf env
+      in 
+        proc _
+          -> do siteName    @ (SiteName    _) <- getSysConfA sc -< ()
+                baseURI     @ (BaseURI     _) <- getSysConfA sc -< ()
+                defaultPage @ (DefaultPage _) <- getSysConfA sc -< ()
+                styleSheet  @ (StyleSheet  _) <- getSysConfA sc -< ()
+                languages   @ (Languages   _) <- getSysConfA sc -< ()
+                globalLock  @ (GlobalLock  _) <- getSysConfA sc -< ()
+
+                ( eelem "/"
+                  += ( eelem "systemConfig"
+                       += ( eelem "value"
+                            += sattr "path" (confPath siteName)
+                            += txt (serialize siteName)
+                          )
+                       += ( eelem "value"
+                            += sattr "path" (confPath baseURI)
+                            += txt (serialize baseURI)
+                          )
+                       += ( eelem "value"
+                            += sattr "path" (confPath defaultPage)
+                            += txt (serialize defaultPage)
+                          )
+                       += ( eelem "value"
+                            += sattr "path" (confPath styleSheet)
+                            += txt (serialize styleSheet)
+                          )
+                       += ( eelem "value"
+                            += sattr "path" (confPath languages)
+                            += txt (serialize languages)
+                          )
+                       += ( eelem "value"
+                            += sattr "path" (confPath globalLock)
+                            += txt (serialize globalLock)
+                          )
+                     ) ) -<< ()
+
+
+handlePut :: Environment -> Resource ()
+handlePut _
+    = fail "NOT IMPL"