module Rakka.SystemConfig
    ( SystemConfig
    , SysConfValue(..)

    , mkSystemConfig -- private

    , getSysConf
    , getSysConfA
    )
    where

import           Control.Arrow.ArrowIO
import           Control.Concurrent.STM
import           Control.Monad.Trans
import qualified Data.ByteString.Char8 as C8
import           Data.Encoding
import           Data.Encoding.UTF8
import           Data.Map (Map)
import qualified Data.Map as M
import           Data.Maybe
import           GHC.Conc (unsafeIOToSTM)
import           Network
import qualified Network.HTTP.Lucu.Config as LC
import           Network.HTTP.Lucu.Utils
import           Network.URI
import           Rakka.Page
import           Rakka.Utils
import           Subversion.FileSystem
import           Subversion.FileSystem.Revision
import           Subversion.FileSystem.Root
import           Subversion.Repository
import           System.FilePath.Posix
import           System.Log.Logger

logger = "Rakka.SystemConfig"


data SystemConfig = SystemConfig {
      scLucuConf   :: !LC.Config
    , scRepository :: !Repository
    , scCache      :: !(TVar (Map FilePath SysConfValue))
    }


data SysConfValue
    = SiteName String
    | BaseURI URI
    | DefaultPage String
    | StyleSheet String
    | Languages (Map LanguageTag LanguageName)
    deriving (Eq, Show)


mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig
mkSystemConfig lc repos
    = do cache <- newTVarIO M.empty
         return $ SystemConfig {
                      scLucuConf   = lc
                    , scRepository = repos
                    , scCache      = cache
                    }


getSysConf :: MonadIO m => SystemConfig -> SysConfValue -> m SysConfValue
getSysConf sc key
    = liftIO $
      atomically $
      do let path = sysConfPath key

         cache <- readTVar (scCache sc)

         case M.lookup path cache of
           Just val -> return val
           Nothing  -> do val <- unsafeIOToSTM (getSysConf' sc key)
                          writeTVar (scCache sc) (M.insert path val cache)
                          return val


getSysConf' :: SystemConfig -> SysConfValue -> IO SysConfValue
getSysConf' sc key
    = do let path = fromConfPath (sysConfPath key)

         fs    <- getRepositoryFS (scRepository sc)
         rev   <- getYoungestRev fs
         value <- withRevision fs rev
                  $ do exists <- isFile path
                       case exists of
                         True
                             -> do str <- getFileContentsLBS path
                                   return $ Just $ chomp $ decodeLazy UTF8 str
                         False
                             -> return Nothing

         case value of
           Just str
               -> do let val = unmarshalSysConf key str
                     debugM logger ("Got a config value at `" ++ path ++ "': " ++ show val)
                     return val
           Nothing
               -> do val <- sysConfDefault sc key
                     debugM logger ("Got no config value at `" ++ path ++ "'. Defaulting to " ++ show val)
                     return val


getSysConfA :: ArrowIO a => SystemConfig -> SysConfValue -> a b SysConfValue
getSysConfA = (arrIO0 .) . getSysConf


fromConfPath :: FilePath -> FilePath
fromConfPath = combine "/config"


marshalStringPairs :: [(String, String)] -> String
marshalStringPairs = joinWith "\n" . map marshalPair'
    where
      marshalPair' :: (String, String) -> String
      marshalPair' (a, b) = a ++ " " ++ b


unmarshalStringPairs :: String -> [(String, String)]
unmarshalStringPairs = catMaybes . map unmarshalPair' . lines
    where
      unmarshalPair' :: String -> Maybe (String, String)
      unmarshalPair' s = case break (/= ' ') s of
                           (a, ' ':b) -> Just (a, b)
                           _          -> Nothing


{- paths -}
sysConfPath :: SysConfValue -> FilePath
sysConfPath (SiteName    _) = "siteName"
sysConfPath (BaseURI     _) = "baseURI"
sysConfPath (DefaultPage _) = "defaultPage"
sysConfPath (StyleSheet  _) = "styleSheet"
sysConfPath (Languages   _) = "languages"


{- marshalling -}
marshalSysConf :: SysConfValue -> String
marshalSysConf (SiteName    name ) = name
marshalSysConf (BaseURI     uri  ) = uriToString id uri ""
marshalSysConf (DefaultPage name ) = name
marshalSysConf (StyleSheet  name ) = name
marshalSysConf (Languages   langs) = marshalStringPairs (M.toList langs)


{- unmarshalling -}
unmarshalSysConf :: SysConfValue -> String -> SysConfValue
unmarshalSysConf (SiteName    _) name  = SiteName name
unmarshalSysConf (BaseURI     _) uri   = BaseURI $ fromJust $ parseURI uri
unmarshalSysConf (DefaultPage _) name  = DefaultPage name
unmarshalSysConf (StyleSheet  _) name  = StyleSheet name
unmarshalSysConf (Languages   _) langs = Languages $ M.fromList $ unmarshalStringPairs langs


{- getting default value -}
sysConfDefault :: SystemConfig -> SysConfValue -> IO SysConfValue

sysConfDefault _ (SiteName _)
    = return $ SiteName "Rakka"

sysConfDefault sc (BaseURI _)
    = do let conf = scLucuConf sc
             host = C8.unpack $ LC.cnfServerHost conf
             port = case LC.cnfServerPort conf of
                      PortNumber num -> fromIntegral num
             
             defaultURI
                  = "http://" ++ host ++
                    (if port == 80
                     then ""
                     else ':' : show port) ++ "/"

         return $ BaseURI $ fromJust $ parseURI defaultURI

sysConfDefault _ (DefaultPage _)
    = return $ DefaultPage "MainPage"

sysConfDefault _ (StyleSheet _)
    = return $ StyleSheet "StyleSheet/Default"

sysConfDefault _ (Languages _)
    = return
      $ Languages
      $ M.fromList [ ("en", "English"  )
                   , ("es", "Español"  )
                   , ("de", "Deutsch"  )
                   , ("fi", "Suomi"    )
                   , ("fr", "Français" )
                   , ("ga", "Gaeilge"  )
                   , ("gd", "Gàidhlig" )
                   , ("ja", "日本語"  )
                   , ("pt", "Português")
                   , ("sv", "Svenska"  )
                   ]