Rakka/Resource/SystemConfig.hs

   1 module Rakka.Resource.SystemConfig
   2     ( resSystemConfig
   3     )
   4     where
   5 import           Data.Maybe
   6 import           Network.HTTP.Lucu
   7 import           Rakka.Environment
   8 import           Rakka.Resource
   9 import           Rakka.SystemConfig
  10 import           Text.XML.HXT.XPath
  11
  12
  13 -- FIXME:
  14 -- GET /systemConfig          ==> 全設定値を返す
  15 -- GET /systemConfig/siteName ==> siteName を返す
  16 -- PUT /systemConfig/siteName ==> siteName を設定
  17 resSystemConfig :: Environment -> ResourceDef
  18 resSystemConfig env
  19     = ResourceDef {
  20         resUsesNativeThread = False
  21       , resIsGreedy         = False
  22       , resGet              = Just $ handleGet env
  23       , resHead             = Nothing
  24       , resPost             = Nothing
  25       , resPut              = Just $ handlePut env
  26       , resDelete           = Nothing
  27       }
  28
  29
  30 {-
  31   <systemConfig>
  32     <value path="siteName">Rakka</value>
  33     <value path="defaultPage">MainPage</value>
  34   </systemConfig>
  35 -}
  36 handleGet :: Environment -> Resource ()
  37 handleGet env
  38     = runIdempotentA' $ proc ()
  39     -> do tree <- mkSystemConfigTree env -< ()
  40           returnA -< outputXml tree
  41
  42
  43 mkSystemConfigTree :: (ArrowXml a, ArrowIO a) => Environment -> a b XmlTree
  44 mkSystemConfigTree env
  45     = let sc = envSysConf env
  46       in
  47         proc _
  48           -> do siteName    @ (SiteName    _) <- getSysConfA sc -< ()
  49                 baseURI     @ (BaseURI     _) <- getSysConfA sc -< ()
  50                 defaultPage @ (DefaultPage _) <- getSysConfA sc -< ()
  51                 styleSheet  @ (StyleSheet  _) <- getSysConfA sc -< ()
  52                 languages   @ (Languages   _) <- getSysConfA sc -< ()
  53                 globalLock  @ (GlobalLock  _) <- getSysConfA sc -< ()
  54
  55                 ( eelem "/"
  56                   += ( eelem "systemConfig"
  57                        += ( eelem "value"
  58                             += sattr "path" (confPath siteName)
  59                             += txt (serialize siteName)
  60                           )
  61                        += ( eelem "value"
  62                             += sattr "path" (confPath baseURI)
  63                             += txt (serialize baseURI)
  64                           )
  65                        += ( eelem "value"
  66                             += sattr "path" (confPath defaultPage)
  67                             += txt (serialize defaultPage)
  68                           )
  69                        += ( eelem "value"
  70                             += sattr "path" (confPath styleSheet)
  71                             += txt (serialize styleSheet)
  72                           )
  73                        += ( eelem "value"
  74                             += sattr "path" (confPath languages)
  75                             += txt (serialize languages)
  76                           )
  77                        += ( eelem "value"
  78                             += sattr "path" (confPath globalLock)
  79                             += txt (serialize globalLock)
  80                           )
  81                      ) ) -<< ()
  82
  83
  84 handlePut :: Environment -> Resource ()
  85 handlePut env
  86     = do let sc = envSysConf env
  87
  88          userID <- getUserID env
  89          case userID of
  90            Nothing
  91                -> setStatus Forbidden
  92            Just uid
  93                -> runXmlA env "rakka-config-1.0.rng" $ proc tree
  94                      -> do listA ( getXPathTreesInDoc "/systemConfig/value"
  95                                    >>>
  96                                    choiceA [ branch (undefined :: SiteName   )
  97                                            , branch (undefined :: BaseURI    )
  98                                            , branch (undefined :: DefaultPage)
  99                                            , branch (undefined :: StyleSheet )
 100                                            , branch (undefined :: Languages  )
 101                                            , branch (undefined :: GlobalLock )
 102                                            ]
 103                                  ) -< tree
 104                            returnA -< setStatus Ok
 105              where
 106              branch :: forall a c. (ArrowXml a, ArrowIO a, SysConfValue c) =>
 107                        c
 108                     -> IfThen (a XmlTree XmlTree) (a XmlTree StatusCode)
 109              branch c
 110                  = hasAttrValue "path" (== confPath c)
 111                    :->
 112                    ( getChildren
 113                      >>> getText
 114                      >>> arr (fromJust . (deserialize :: String -> Maybe c))
 115                      >>> setSysConfA sc uid )