+{-# LANGUAGE
+ Arrows
+ , RecordWildCards
+ , ScopedTypeVariables
+ , TypeOperators
+ , UnicodeSyntax
+ #-}
module Rakka.Resource.SystemConfig
( resSystemConfig
)
where
-
+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
-
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.DOM.TypeDefs
+import Text.XML.HXT.XPath
-- FIXME:
-- GET /systemConfig ==> 全設定値を返す
, resDelete = Nothing
}
-
{-
<systemConfig>
<value path="siteName">Rakka</value>
-> 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 (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)
- )
- ) ) -<< ()
+ ( 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)
+ )
+ ) ) ⤛ ()
-
-handlePut :: Environment -> Resource ()
-handlePut env
- = do let sc = envSysConf env
-
- userID <- getUserID env
- case userID of
- Nothing
- -> setStatus Forbidden
- Just uid
- -> runXmlA env "rakka-config-1.0.rng" $ proc tree
- -> do listA ( getXPathTreesInDoc "/systemConfig/value"
- >>>
- choiceA [ branch (undefined :: SiteName )
- , branch (undefined :: BaseURI )
- , branch (undefined :: DefaultPage)
- , branch (undefined :: StyleSheet )
- , branch (undefined :: Languages )
- , branch (undefined :: GlobalLock )
- ]
- ) -< tree
- returnA -< setStatus Ok
- where
- branch :: forall a c. (ArrowXml a, ArrowIO a, SysConfValue c) =>
- c
- -> IfThen (a XmlTree XmlTree) (a XmlTree StatusCode)
- branch c
- = hasAttrValue "path" (== confPath c)
- :->
- ( getChildren
- >>> getText
- >>> arr (fromJust . (deserialize :: String -> Maybe c))
- >>> setSysConfA sc uid )
\ No newline at end of file
+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 )