1 module Rakka.Resource.SystemConfig
7 import Control.Arrow.ArrowIO
8 import Control.Monad.Trans
9 import Network.HTTP.Lucu
10 import Rakka.Environment
11 import Rakka.SystemConfig
12 import Text.XML.HXT.Arrow.WriteDocument
13 import Text.XML.HXT.Arrow.XmlArrow
14 import Text.XML.HXT.Arrow.XmlIOStateArrow
15 import Text.XML.HXT.DOM.TypeDefs
16 import Text.XML.HXT.DOM.XmlKeywords
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 = do setContentType $ read "text/xml"
41 [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
43 mkSystemConfigTree env
45 writeDocumentToString [ (a_indent, v_1) ]
50 mkSystemConfigTree :: (ArrowXml a, ArrowIO a) => Environment -> a b XmlTree
51 mkSystemConfigTree env
52 = let sc = envSysConf env
55 -> do siteName @ (SiteName _) <- getSysConfA sc -< ()
56 baseURI @ (BaseURI _) <- getSysConfA sc -< ()
57 defaultPage @ (DefaultPage _) <- getSysConfA sc -< ()
58 styleSheet @ (StyleSheet _) <- getSysConfA sc -< ()
59 languages @ (Languages _) <- getSysConfA sc -< ()
60 globalLock @ (GlobalLock _) <- getSysConfA sc -< ()
63 += ( eelem "systemConfig"
65 += sattr "path" (confPath siteName)
66 += txt (serialize siteName)
69 += sattr "path" (confPath baseURI)
70 += txt (serialize baseURI)
73 += sattr "path" (confPath defaultPage)
74 += txt (serialize defaultPage)
77 += sattr "path" (confPath styleSheet)
78 += txt (serialize styleSheet)
81 += sattr "path" (confPath languages)
82 += txt (serialize languages)
85 += sattr "path" (confPath globalLock)
86 += txt (serialize globalLock)
91 handlePut :: Environment -> Resource ()