)
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 {
-}
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
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