X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FResource%2FSystemConfig.hs;h=cb19011b1f3c4b6746095b21e557668b57e41fca;hb=fcddebcc3cc02ae8d1904b9338334d538019e74a;hp=110ecc195143ceb3748d9831272c3252601830f9;hpb=522dde5470584bb3f82cb0b4179233724d2408d0;p=Rakka.git

diff --git a/Rakka/Resource/SystemConfig.hs b/Rakka/Resource/SystemConfig.hs
index 110ecc1..cb19011 100644
--- a/Rakka/Resource/SystemConfig.hs
+++ b/Rakka/Resource/SystemConfig.hs
@@ -3,19 +3,19 @@ module Rakka.Resource.SystemConfig
     )
     where
 
-import           Control.Arrow
-import           Control.Arrow.ArrowIO
-import           Control.Monad.Trans
+import           Data.Maybe
 import           Network.HTTP.Lucu
 import           Rakka.Environment
+import           Rakka.Resource
 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
+import           Text.XML.HXT.Arrow
+import           Text.XML.HXT.XPath
 
 
+-- FIXME:
+-- GET /systemConfig          ==> 全設定値を返す
+-- GET /systemConfig/siteName ==> siteName を返す
+-- PUT /systemConfig/siteName ==> siteName を設定
 resSystemConfig :: Environment -> ResourceDef
 resSystemConfig env
     = ResourceDef {
@@ -37,14 +37,9 @@ resSystemConfig env
 -}
 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
+    = runIdempotentA' $ proc ()
+    -> do tree <- mkSystemConfigTree env -< ()
+	  returnA -< outputXml tree
 
 
 mkSystemConfigTree :: (ArrowXml a, ArrowIO a) => Environment -> a b XmlTree
@@ -89,5 +84,34 @@ mkSystemConfigTree env
 
 
 handlePut :: Environment -> Resource ()
-handlePut _
-    = fail "NOT IMPL"
+handlePut env
+    = do let sc = envSysConf env
+
+	 userID <- getUserID env
+	 case userID of
+	   Nothing
+	       -> setStatus Forbidden
+	   Just uid
+	       -> runXmlA env "rakka-config-1.0.rng" $ proc tree
+		     -> do listA ( getXPathTreesInDoc "/systemConfig/value"
+				   >>>
+				   choiceA [ branch (undefined :: SiteName   )
+					   , branch (undefined :: BaseURI    )
+					   , branch (undefined :: DefaultPage)
+					   , branch (undefined :: StyleSheet )
+					   , branch (undefined :: Languages  )
+					   , branch (undefined :: GlobalLock )
+					   ]
+				 ) -< tree
+			   returnA -< setStatus Ok
+	     where
+	     branch :: forall a c. (ArrowXml a, ArrowIO a, SysConfValue c) =>
+		       c
+		    -> IfThen (a XmlTree XmlTree) (a XmlTree StatusCode)
+	     branch c
+		 = hasAttrValue "path" (== confPath c)
+		   :->
+		   ( getChildren
+		     >>> getText
+		     >>> arr (fromJust . (deserialize :: String -> Maybe c))
+		     >>> setSysConfA sc uid )
\ No newline at end of file