Rakka/Resource/SystemConfig.hs

   1 module Rakka.Resource.SystemConfig
   2     ( resSystemConfig
   3     )
   4     where
   5
   6 import           Control.Monad.Trans
   7 import           Data.Maybe
   8 import           Network.HTTP.Lucu
   9 import           Rakka.Environment
  10 import           Rakka.Resource
  11 import           Rakka.SystemConfig
  12 import           Text.XML.HXT.Arrow
  13
  14
  15 resSystemConfig :: Environment -> ResourceDef
  16 resSystemConfig env
  17     = ResourceDef {
  18         resUsesNativeThread = False
  19       , resIsGreedy         = False
  20       , resGet              = Just $ handleGet env
  21       , resHead             = Nothing
  22       , resPost             = Nothing
  23       , resPut              = Just $ handlePut env
  24       , resDelete           = Nothing
  25       }
  26
  27
  28 {-
  29   <systemConfig>
  30     <value path="siteName">Rakka</value>
  31     <value path="defaultPage">MainPage</value>
  32   </systemConfig>
  33 -}
  34 handleGet :: Environment -> Resource ()
  35 handleGet env
  36     = do setContentType $ read "text/xml"
  37          [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
  38                                      >>>
  39                                      mkSystemConfigTree env
  40                                      >>>
  41                                      writeDocumentToString [ (a_indent, v_1) ]
  42                                    )
  43          output xmlStr
  44
  45
  46 mkSystemConfigTree :: (ArrowXml a, ArrowIO a) => Environment -> a b XmlTree
  47 mkSystemConfigTree env
  48     = let sc = envSysConf env
  49       in
  50         proc _
  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 -< ()
  57
  58                 ( eelem "/"
  59                   += ( eelem "systemConfig"
  60                        += ( eelem "value"
  61                             += sattr "path" (confPath siteName)
  62                             += txt (serialize siteName)
  63                           )
  64                        += ( eelem "value"
  65                             += sattr "path" (confPath baseURI)
  66                             += txt (serialize baseURI)
  67                           )
  68                        += ( eelem "value"
  69                             += sattr "path" (confPath defaultPage)
  70                             += txt (serialize defaultPage)
  71                           )
  72                        += ( eelem "value"
  73                             += sattr "path" (confPath styleSheet)
  74                             += txt (serialize styleSheet)
  75                           )
  76                        += ( eelem "value"
  77                             += sattr "path" (confPath languages)
  78                             += txt (serialize languages)
  79                           )
  80                        += ( eelem "value"
  81                             += sattr "path" (confPath globalLock)
  82                             += txt (serialize globalLock)
  83                           )
  84                      ) ) -<< ()
  85
  86
  87 handlePut :: Environment -> Resource ()
  88 handlePut env
  89     = do let sc = envSysConf env
  90
  91          userID <- getUserID env
  92          case userID of
  93            Nothing
  94                -> setStatus Forbidden
  95            Just uid
  96                -> runXmlA env "rakka-config-1.0.rng" $ proc tree
  97                      -> do listA ( getXPathTreesInDoc "/systemConfig/value"
  98                                    >>>
  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 )
 105                                            ]
 106                                  ) -< tree
 107                            returnA -< setStatus Ok
 108              where
 109              branch :: forall a c. (ArrowXml a, ArrowIO a, SysConfValue c) =>
 110                        c
 111                     -> IfThen (a XmlTree XmlTree) (a XmlTree StatusCode)
 112              branch c
 113                  = hasAttrValue "path" (== confPath c)
 114                    :->
 115                    ( getChildren
 116                      >>> getText
 117                      >>> arr (fromJust . (deserialize :: String -> Maybe c))
 118                      >>> setSysConfA sc uid )