{-# 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.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 {
        resUsesNativeThread = False
      , resIsGreedy         = False
      , resGet              = Just $ handleGet env
      , resHead             = Nothing
      , resPost             = Nothing
      , resPut              = Just $ handlePut env
      , resDelete           = Nothing
      }

{-
  <systemConfig>
    <value path="siteName">Rakka</value>
    <value path="defaultPage">MainPage</value>
  </systemConfig>
-}
handleGet :: Environment -> Resource ()
handleGet env
    = 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 ⤙ ()

         ( 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@(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 )