/systemConfig now works

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

diff --git a/Rakka/Resource/SystemConfig.hs b/Rakka/Resource/SystemConfig.hs
index 110ecc195143ceb3748d9831272c3252601830f9..beae8316994a2389baebba8d5236c9569a0fe589 100644 (file)
--- a/Rakka/Resource/SystemConfig.hs
+++ b/Rakka/Resource/SystemConfig.hs
@@ -3,17 +3,13 @@ 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
 
 
 resSystemConfig :: Environment -> ResourceDef
@@ -89,5 +85,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