+{-# LANGUAGE
+ Arrows
+ , RecordWildCards
+ , ScopedTypeVariables
+ , TypeOperators
+ , UnicodeSyntax
+ #-}
module Rakka.Resource.SystemConfig
( resSystemConfig
)
where
-
-import Control.Arrow
-import Control.Arrow.ArrowIO
-import Control.Monad.Trans
+import Control.Arrow
+import Control.Arrow.ArrowIf
+import Control.Arrow.ArrowIO
+import Control.Arrow.ArrowList
+import Control.Arrow.ArrowTree
+import Control.Arrow.Unicode
+import Data.Maybe
+import Data.Text (Text)
+import qualified Data.Text as T
import Network.HTTP.Lucu
+import Prelude.Unicode
import Rakka.Environment
+import Rakka.Resource
import Rakka.SystemConfig
-import Text.XML.HXT.Arrow.WriteDocument
-import Text.XML.HXT.Arrow.XmlArrow
-import Text.XML.HXT.Arrow.XmlIOStateArrow
-import Text.XML.HXT.DOM.TypeDefs
-import Text.XML.HXT.DOM.XmlKeywords
-
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.DOM.TypeDefs
+import Text.XML.HXT.XPath
+-- FIXME:
+-- GET /systemConfig ==> 全設定値を返す
+-- GET /systemConfig/siteName ==> siteName を返す
+-- PUT /systemConfig/siteName ==> siteName を設定
resSystemConfig :: Environment -> ResourceDef
resSystemConfig env
= ResourceDef {
, resDelete = Nothing
}
-
{-
<systemConfig>
<value path="siteName">Rakka</value>
-}
handleGet :: Environment -> Resource ()
handleGet env
- = do setContentType $ read "text/xml"
- [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
- >>>
- mkSystemConfigTree env
- >>>
- writeDocumentToString [ (a_indent, v_1) ]
- )
- output xmlStr
+ = runIdempotentA' $ proc ()
+ -> do tree <- mkSystemConfigTree env -< ()
+ returnA -< outputXml tree
+mkSystemConfigTree ∷ (ArrowXml (⇝), ArrowIO (⇝)) ⇒ Environment → β ⇝ XmlTree
+mkSystemConfigTree (Environment {..})
+ = proc _ →
+ do siteName @ (SiteName _) ← getSysConfA envSysConf ⤙ ()
+ baseURI @ (BaseURI _) ← getSysConfA envSysConf ⤙ ()
+ defaultPage @ (DefaultPage _) ← getSysConfA envSysConf ⤙ ()
+ styleSheet @ (StyleSheet _) ← getSysConfA envSysConf ⤙ ()
+ languages @ (Languages _) ← getSysConfA envSysConf ⤙ ()
+ globalLock @ (GlobalLock _) ← getSysConfA envSysConf ⤙ ()
-mkSystemConfigTree :: (ArrowXml a, ArrowIO a) => Environment -> a b XmlTree
-mkSystemConfigTree env
- = let sc = envSysConf env
- in
- proc _
- -> do siteName @ (SiteName _) <- getSysConfA sc -< ()
- baseURI @ (BaseURI _) <- getSysConfA sc -< ()
- defaultPage @ (DefaultPage _) <- getSysConfA sc -< ()
- styleSheet @ (StyleSheet _) <- getSysConfA sc -< ()
- languages @ (Languages _) <- getSysConfA sc -< ()
- globalLock @ (GlobalLock _) <- getSysConfA sc -< ()
+ ( eelem "/"
+ += ( eelem "systemConfig"
+ += ( eelem "value"
+ += sattr "path" (confPath siteName)
+ += txt (T.unpack $ serialize siteName)
+ )
+ += ( eelem "value"
+ += sattr "path" (confPath baseURI)
+ += txt (T.unpack $ serialize baseURI)
+ )
+ += ( eelem "value"
+ += sattr "path" (confPath defaultPage)
+ += txt (T.unpack $ serialize defaultPage)
+ )
+ += ( eelem "value"
+ += sattr "path" (confPath styleSheet)
+ += txt (T.unpack $ serialize styleSheet)
+ )
+ += ( eelem "value"
+ += sattr "path" (confPath languages)
+ += txt (T.unpack $ serialize languages)
+ )
+ += ( eelem "value"
+ += sattr "path" (confPath globalLock)
+ += txt (T.unpack $ serialize globalLock)
+ )
+ ) ) ⤛ ()
- ( eelem "/"
- += ( eelem "systemConfig"
- += ( eelem "value"
- += sattr "path" (confPath siteName)
- += txt (serialize siteName)
- )
- += ( eelem "value"
- += sattr "path" (confPath baseURI)
- += txt (serialize baseURI)
- )
- += ( eelem "value"
- += sattr "path" (confPath defaultPage)
- += txt (serialize defaultPage)
- )
- += ( eelem "value"
- += sattr "path" (confPath styleSheet)
- += txt (serialize styleSheet)
- )
- += ( eelem "value"
- += sattr "path" (confPath languages)
- += txt (serialize languages)
- )
- += ( eelem "value"
- += sattr "path" (confPath globalLock)
- += txt (serialize globalLock)
- )
- ) ) -<< ()
-
-
-handlePut :: Environment -> Resource ()
-handlePut _
- = fail "NOT IMPL"
+handlePut ∷ Environment → Resource ()
+handlePut env@(Environment {..})
+ = do userID ← getUserID env
+ case userID of
+ Nothing
+ → setStatus Forbidden
+ Just uid
+ → runXmlA "rakka-config-1.0.rng" $ proc tree
+ → do listA ( getXPathTreesInDoc "/systemConfig/value"
+ ⋙
+ choiceA [ branch uid ((⊥) ∷ SiteName )
+ , branch uid ((⊥) ∷ BaseURI )
+ , branch uid ((⊥) ∷ DefaultPage)
+ , branch uid ((⊥) ∷ StyleSheet )
+ , branch uid ((⊥) ∷ Languages )
+ , branch uid ((⊥) ∷ GlobalLock )
+ ]
+ ) ⤙ tree
+ returnA ⤙ setStatus Ok
+ where
+ branch ∷ ∀(⇝) c. (ArrowXml (⇝), ArrowIO (⇝), SysConfValue c)
+ ⇒ String
+ → c
+ → IfThen (XmlTree ⇝ XmlTree) (XmlTree ⇝ StatusCode)
+ branch uid c
+ = hasAttrValue "path" (≡ confPath c)
+ :->
+ ( getChildren
+ ⋙ getText
+ ⋙ arr (fromJust ∘ (deserialize ∷ Text → Maybe c) ∘ T.pack)
+ ⋙ setSysConfA envSysConf uid )