8 module Rakka.Resource.SystemConfig
13 import Control.Arrow.ArrowIf
14 import Control.Arrow.ArrowIO
15 import Control.Arrow.ArrowList
16 import Control.Arrow.ArrowTree
17 import Control.Arrow.Unicode
19 import Data.Text (Text)
20 import qualified Data.Text as T
21 import Network.HTTP.Lucu
22 import Prelude.Unicode
23 import Rakka.Environment
25 import Rakka.SystemConfig
26 import Text.XML.HXT.Arrow.XmlArrow
27 import Text.XML.HXT.DOM.TypeDefs
28 import Text.XML.HXT.XPath
31 -- GET /systemConfig ==> 全設定値を返す
32 -- GET /systemConfig/siteName ==> siteName を返す
33 -- PUT /systemConfig/siteName ==> siteName を設定
34 resSystemConfig :: Environment -> ResourceDef
37 resUsesNativeThread = False
39 , resGet = Just $ handleGet env
42 , resPut = Just $ handlePut env
48 <value path="siteName">Rakka</value>
49 <value path="defaultPage">MainPage</value>
52 handleGet :: Environment -> Resource ()
54 = runIdempotentA' $ proc ()
55 -> do tree <- mkSystemConfigTree env -< ()
56 returnA -< outputXml tree
58 mkSystemConfigTree ∷ (ArrowXml (⇝), ArrowIO (⇝)) ⇒ Environment → β ⇝ XmlTree
59 mkSystemConfigTree (Environment {..})
61 do siteName @ (SiteName _) ← getSysConfA envSysConf ⤙ ()
62 baseURI @ (BaseURI _) ← getSysConfA envSysConf ⤙ ()
63 defaultPage @ (DefaultPage _) ← getSysConfA envSysConf ⤙ ()
64 styleSheet @ (StyleSheet _) ← getSysConfA envSysConf ⤙ ()
65 languages @ (Languages _) ← getSysConfA envSysConf ⤙ ()
66 globalLock @ (GlobalLock _) ← getSysConfA envSysConf ⤙ ()
69 += ( eelem "systemConfig"
71 += sattr "path" (confPath siteName)
72 += txt (T.unpack $ serialize siteName)
75 += sattr "path" (confPath baseURI)
76 += txt (T.unpack $ serialize baseURI)
79 += sattr "path" (confPath defaultPage)
80 += txt (T.unpack $ serialize defaultPage)
83 += sattr "path" (confPath styleSheet)
84 += txt (T.unpack $ serialize styleSheet)
87 += sattr "path" (confPath languages)
88 += txt (T.unpack $ serialize languages)
91 += sattr "path" (confPath globalLock)
92 += txt (T.unpack $ serialize globalLock)
96 handlePut ∷ Environment → Resource ()
97 handlePut env@(Environment {..})
98 = do userID ← getUserID env
101 → setStatus Forbidden
103 → runXmlA "rakka-config-1.0.rng" $ proc tree
104 → do listA ( getXPathTreesInDoc "/systemConfig/value"
106 choiceA [ branch uid ((⊥) ∷ SiteName )
107 , branch uid ((⊥) ∷ BaseURI )
108 , branch uid ((⊥) ∷ DefaultPage)
109 , branch uid ((⊥) ∷ StyleSheet )
110 , branch uid ((⊥) ∷ Languages )
111 , branch uid ((⊥) ∷ GlobalLock )
114 returnA ⤙ setStatus Ok
116 branch ∷ ∀(⇝) c. (ArrowXml (⇝), ArrowIO (⇝), SysConfValue c)
119 → IfThen (XmlTree ⇝ XmlTree) (XmlTree ⇝ StatusCode)
121 = hasAttrValue "path" (≡ confPath c)
125 ⋙ arr (fromJust ∘ (deserialize ∷ Text → Maybe c) ∘ T.pack)
126 ⋙ setSysConfA envSysConf uid )