Rakka/Resource/SystemConfig.hs

   1 module Rakka.Resource.SystemConfig
   2     ( resSystemConfig
   3     )
   4     where
   5
   6 import           Control.Arrow
   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
  17
  18
  19 resSystemConfig :: Environment -> ResourceDef
  20 resSystemConfig env
  21     = ResourceDef {
  22         resUsesNativeThread = False
  23       , resIsGreedy         = False
  24       , resGet              = Just $ handleGet env
  25       , resHead             = Nothing
  26       , resPost             = Nothing
  27       , resPut              = Just $ handlePut env
  28       , resDelete           = Nothing
  29       }
  30
  31
  32 {-
  33   <systemConfig>
  34     <value path="siteName">Rakka</value>
  35     <value path="defaultPage">MainPage</value>
  36   </systemConfig>
  37 -}
  38 handleGet :: Environment -> Resource ()
  39 handleGet env
  40     = do setContentType $ read "text/xml"
  41          [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
  42                                      >>>
  43                                      mkSystemConfigTree env
  44                                      >>>
  45                                      writeDocumentToString [ (a_indent, v_1) ]
  46                                    )
  47          output xmlStr
  48
  49
  50 mkSystemConfigTree :: (ArrowXml a, ArrowIO a) => Environment -> a b XmlTree
  51 mkSystemConfigTree env
  52     = let sc = envSysConf env
  53       in
  54         proc _
  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 -< ()
  61
  62                 ( eelem "/"
  63                   += ( eelem "systemConfig"
  64                        += ( eelem "value"
  65                             += sattr "path" (confPath siteName)
  66                             += txt (serialize siteName)
  67                           )
  68                        += ( eelem "value"
  69                             += sattr "path" (confPath baseURI)
  70                             += txt (serialize baseURI)
  71                           )
  72                        += ( eelem "value"
  73                             += sattr "path" (confPath defaultPage)
  74                             += txt (serialize defaultPage)
  75                           )
  76                        += ( eelem "value"
  77                             += sattr "path" (confPath styleSheet)
  78                             += txt (serialize styleSheet)
  79                           )
  80                        += ( eelem "value"
  81                             += sattr "path" (confPath languages)
  82                             += txt (serialize languages)
  83                           )
  84                        += ( eelem "value"
  85                             += sattr "path" (confPath globalLock)
  86                             += txt (serialize globalLock)
  87                           )
  88                      ) ) -<< ()
  89
  90
  91 handlePut :: Environment -> Resource ()
  92 handlePut _
  93     = fail "NOT IMPL"