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 import           Text.XML.HXT.XPath
  13
  14
  15 -- FIXME:
  16 -- GET /systemConfig          ==> 全設定値を返す
  17 -- GET /systemConfig/siteName ==> siteName を返す
  18 -- PUT /systemConfig/siteName ==> siteName を設定
  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     = runIdempotentA' $ proc ()
  41     -> do tree <- mkSystemConfigTree env -< ()
  42           returnA -< outputXml tree
  43
  44
  45 mkSystemConfigTree :: (ArrowXml a, ArrowIO a) => Environment -> a b XmlTree
  46 mkSystemConfigTree env
  47     = let sc = envSysConf env
  48       in
  49         proc _
  50           -> do siteName    @ (SiteName    _) <- getSysConfA sc -< ()
  51                 baseURI     @ (BaseURI     _) <- getSysConfA sc -< ()
  52                 defaultPage @ (DefaultPage _) <- getSysConfA sc -< ()
  53                 styleSheet  @ (StyleSheet  _) <- getSysConfA sc -< ()
  54                 languages   @ (Languages   _) <- getSysConfA sc -< ()
  55                 globalLock  @ (GlobalLock  _) <- getSysConfA sc -< ()
  56
  57                 ( eelem "/"
  58                   += ( eelem "systemConfig"
  59                        += ( eelem "value"
  60                             += sattr "path" (confPath siteName)
  61                             += txt (serialize siteName)
  62                           )
  63                        += ( eelem "value"
  64                             += sattr "path" (confPath baseURI)
  65                             += txt (serialize baseURI)
  66                           )
  67                        += ( eelem "value"
  68                             += sattr "path" (confPath defaultPage)
  69                             += txt (serialize defaultPage)
  70                           )
  71                        += ( eelem "value"
  72                             += sattr "path" (confPath styleSheet)
  73                             += txt (serialize styleSheet)
  74                           )
  75                        += ( eelem "value"
  76                             += sattr "path" (confPath languages)
  77                             += txt (serialize languages)
  78                           )
  79                        += ( eelem "value"
  80                             += sattr "path" (confPath globalLock)
  81                             += txt (serialize globalLock)
  82                           )
  83                      ) ) -<< ()
  84
  85
  86 handlePut :: Environment -> Resource ()
  87 handlePut env
  88     = do let sc = envSysConf env
  89
  90          userID <- getUserID env
  91          case userID of
  92            Nothing
  93                -> setStatus Forbidden
  94            Just uid
  95                -> runXmlA env "rakka-config-1.0.rng" $ proc tree
  96                      -> do listA ( getXPathTreesInDoc "/systemConfig/value"
  97                                    >>>
  98                                    choiceA [ branch (undefined :: SiteName   )
  99                                            , branch (undefined :: BaseURI    )
 100                                            , branch (undefined :: DefaultPage)
 101                                            , branch (undefined :: StyleSheet )
 102                                            , branch (undefined :: Languages  )
 103                                            , branch (undefined :: GlobalLock )
 104                                            ]
 105                                  ) -< tree
 106                            returnA -< setStatus Ok
 107              where
 108              branch :: forall a c. (ArrowXml a, ArrowIO a, SysConfValue c) =>
 109                        c
 110                     -> IfThen (a XmlTree XmlTree) (a XmlTree StatusCode)
 111              branch c
 112                  = hasAttrValue "path" (== confPath c)
 113                    :->
 114                    ( getChildren
 115                      >>> getText
 116                      >>> arr (fromJust . (deserialize :: String -> Maybe c))
 117                      >>> setSysConfA sc uid )