Rakka/Resource/SystemConfig.hs

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