module Rakka.Resource.SystemConfig
    ( resSystemConfig
    )
    where

import           Control.Monad.Trans
import           Data.Maybe
import           Network.HTTP.Lucu
import           Rakka.Environment
import           Rakka.Resource
import           Rakka.SystemConfig
import           Text.XML.HXT.Arrow


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
    = do setContentType $ read "text/xml"
         [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
                                     >>>
                                     mkSystemConfigTree env
                                     >>>
                                     writeDocumentToString [ (a_indent, v_1) ]
                                   )
         output xmlStr


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


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 )