1 module Rakka.Resource.SystemConfig
6 import Control.Monad.Trans
8 import Network.HTTP.Lucu
9 import Rakka.Environment
11 import Rakka.SystemConfig
12 import Text.XML.HXT.Arrow
15 resSystemConfig :: Environment -> ResourceDef
18 resUsesNativeThread = False
20 , resGet = Just $ handleGet env
23 , resPut = Just $ handlePut env
30 <value path="siteName">Rakka</value>
31 <value path="defaultPage">MainPage</value>
34 handleGet :: Environment -> Resource ()
36 = do setContentType $ read "text/xml"
37 [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
39 mkSystemConfigTree env
41 writeDocumentToString [ (a_indent, v_1) ]
46 mkSystemConfigTree :: (ArrowXml a, ArrowIO a) => Environment -> a b XmlTree
47 mkSystemConfigTree env
48 = let sc = envSysConf env
51 -> do siteName @ (SiteName _) <- getSysConfA sc -< ()
52 baseURI @ (BaseURI _) <- getSysConfA sc -< ()
53 defaultPage @ (DefaultPage _) <- getSysConfA sc -< ()
54 styleSheet @ (StyleSheet _) <- getSysConfA sc -< ()
55 languages @ (Languages _) <- getSysConfA sc -< ()
56 globalLock @ (GlobalLock _) <- getSysConfA sc -< ()
59 += ( eelem "systemConfig"
61 += sattr "path" (confPath siteName)
62 += txt (serialize siteName)
65 += sattr "path" (confPath baseURI)
66 += txt (serialize baseURI)
69 += sattr "path" (confPath defaultPage)
70 += txt (serialize defaultPage)
73 += sattr "path" (confPath styleSheet)
74 += txt (serialize styleSheet)
77 += sattr "path" (confPath languages)
78 += txt (serialize languages)
81 += sattr "path" (confPath globalLock)
82 += txt (serialize globalLock)
87 handlePut :: Environment -> Resource ()
89 = do let sc = envSysConf env
91 userID <- getUserID env
94 -> setStatus Forbidden
96 -> runXmlA env "rakka-config-1.0.rng" $ proc tree
97 -> do listA ( getXPathTreesInDoc "/systemConfig/value"
99 choiceA [ branch (undefined :: SiteName )
100 , branch (undefined :: BaseURI )
101 , branch (undefined :: DefaultPage)
102 , branch (undefined :: StyleSheet )
103 , branch (undefined :: Languages )
104 , branch (undefined :: GlobalLock )
107 returnA -< setStatus Ok
109 branch :: forall a c. (ArrowXml a, ArrowIO a, SysConfValue c) =>
111 -> IfThen (a XmlTree XmlTree) (a XmlTree StatusCode)
113 = hasAttrValue "path" (== confPath c)
117 >>> arr (fromJust . (deserialize :: String -> Maybe c))
118 >>> setSysConfA sc uid )