Resurrection from bitrot

[Rakka.git] / Rakka / Resource / SystemConfig.hs

diff --git a/Rakka/Resource/SystemConfig.hs b/Rakka/Resource/SystemConfig.hs
index cb19011b1f3c4b6746095b21e557668b57e41fca..3ae3f42952d0d08d78362a1eea8a141da5e07c97 100644 (file)
--- a/Rakka/Resource/SystemConfig.hs
+++ b/Rakka/Resource/SystemConfig.hs
@@ -1,16 +1,31 @@
+{-# 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.XPath
-
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.DOM.TypeDefs
+import Text.XML.HXT.XPath
 
 -- FIXME:
 -- GET /systemConfig          ==> 全設定値を返す
@@ -28,7 +43,6 @@ resSystemConfig env
       , resDelete           = Nothing
       }
 
-
 {-
   <systemConfig>
     <value path="siteName">Rakka</value>
@@ -41,77 +55,72 @@ handleGet env
     -> 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 )