Rakka/Resource/SystemConfig.hs

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