1 module Rakka.Resource.SystemConfig
7 import Network.HTTP.Lucu
8 import Rakka.Environment
10 import Rakka.SystemConfig
11 import Text.XML.HXT.Arrow
12 import Text.XML.HXT.XPath
16 -- GET /systemConfig ==> 全設定値を返す
17 -- GET /systemConfig/siteName ==> siteName を返す
18 -- PUT /systemConfig/siteName ==> siteName を設定
19 resSystemConfig :: Environment -> ResourceDef
22 resUsesNativeThread = False
24 , resGet = Just $ handleGet env
27 , resPut = Just $ handlePut env
34 <value path="siteName">Rakka</value>
35 <value path="defaultPage">MainPage</value>
38 handleGet :: Environment -> Resource ()
40 = runIdempotentA' $ proc ()
41 -> do tree <- mkSystemConfigTree env -< ()
42 returnA -< outputXml tree
45 mkSystemConfigTree :: (ArrowXml a, ArrowIO a) => Environment -> a b XmlTree
46 mkSystemConfigTree env
47 = let sc = envSysConf env
50 -> do siteName @ (SiteName _) <- getSysConfA sc -< ()
51 baseURI @ (BaseURI _) <- getSysConfA sc -< ()
52 defaultPage @ (DefaultPage _) <- getSysConfA sc -< ()
53 styleSheet @ (StyleSheet _) <- getSysConfA sc -< ()
54 languages @ (Languages _) <- getSysConfA sc -< ()
55 globalLock @ (GlobalLock _) <- getSysConfA sc -< ()
58 += ( eelem "systemConfig"
60 += sattr "path" (confPath siteName)
61 += txt (serialize siteName)
64 += sattr "path" (confPath baseURI)
65 += txt (serialize baseURI)
68 += sattr "path" (confPath defaultPage)
69 += txt (serialize defaultPage)
72 += sattr "path" (confPath styleSheet)
73 += txt (serialize styleSheet)
76 += sattr "path" (confPath languages)
77 += txt (serialize languages)
80 += sattr "path" (confPath globalLock)
81 += txt (serialize globalLock)
86 handlePut :: Environment -> Resource ()
88 = do let sc = envSysConf env
90 userID <- getUserID env
93 -> setStatus Forbidden
95 -> runXmlA env "rakka-config-1.0.rng" $ proc tree
96 -> do listA ( getXPathTreesInDoc "/systemConfig/value"
98 choiceA [ branch (undefined :: SiteName )
99 , branch (undefined :: BaseURI )
100 , branch (undefined :: DefaultPage)
101 , branch (undefined :: StyleSheet )
102 , branch (undefined :: Languages )
103 , branch (undefined :: GlobalLock )
106 returnA -< setStatus Ok
108 branch :: forall a c. (ArrowXml a, ArrowIO a, SysConfValue c) =>
110 -> IfThen (a XmlTree XmlTree) (a XmlTree StatusCode)
112 = hasAttrValue "path" (== confPath c)
116 >>> arr (fromJust . (deserialize :: String -> Maybe c))
117 >>> setSysConfA sc uid )