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

    , mkSystemConfig -- private

    , getSysConf
    , getSysConfA

    , SiteName(..)
    , BaseURI(..)
    , DefaultPage(..)
    , StyleSheet(..)
    , Languages(..)

    , serializeStringPairs
    , deserializeStringPairs
    )
    where

import           Codec.Binary.UTF8.String
import           Control.Arrow.ArrowIO
import           Control.Concurrent.STM
import           Control.Monad
import           Control.Monad.Trans
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy  as L
import           Data.Dynamic
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 hiding (path)
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 :: String
logger = "Rakka.SystemConfig"


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


class (Typeable a, Show a) => SysConfValue a where
    confPath     :: a -> FilePath
    serialize    :: a -> String
    deserialize  :: String -> Maybe a
    defaultValue :: SystemConfig -> a


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

getSysConf :: forall m a. (MonadIO m, SysConfValue a) => SystemConfig -> m a
getSysConf sc
    = liftIO $
      atomically $
      do let path = confPath (undefined :: a)

         cache <- readTVar (scCache sc)

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


getSysConf' :: forall a. SysConfValue a => SystemConfig -> IO a
getSysConf' sc
    = do let path = fromConfPath $ confPath (undefined :: a)

         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 $ decode $ L.unpack str
                         False
                             -> return Nothing

         case value of
           Just str
               -> case deserialize str of
                    Just val
                        -> do debugM logger ("Got a config value at `" ++ path ++ "': " ++ show val)
                              return val
                    Nothing
                        -> fail ("Got an invalid config value at `" ++ path ++ "': " ++ str)
           Nothing
               -> do let val = defaultValue sc
                     debugM logger ("Got no config value at `" ++ path ++ "'. Defaulting to " ++ show val)
                     return val


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


fromConfPath :: FilePath -> FilePath
fromConfPath = ("/config" </>)


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


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



{- config values -}

newtype SiteName = SiteName String deriving (Show, Typeable)
instance SysConfValue SiteName where
    confPath _                = "siteName"
    serialize (SiteName name) = name
    deserialize name          = Just (SiteName name)
    defaultValue _            = SiteName "Rakka"


newtype BaseURI = BaseURI URI deriving (Show, Typeable)
instance SysConfValue BaseURI where
    confPath _              = "baseURI"
    serialize (BaseURI uri) = uriToString id uri ""
    deserialize uri         = fmap BaseURI
                              $ do parsed <- parseURI uri
                                   when (uriPath parsed        == "" ) (fail undefined)
                                   when (last (uriPath parsed) /= '/') (fail undefined)
                                   when (uriQuery parsed       /= "" ) (fail undefined)
                                   when (uriFragment parsed    /= "" ) (fail undefined)
                                   return parsed
    defaultValue sc
        = let conf = scLucuConf sc
              host = C8.unpack $ LC.cnfServerHost conf
              port = case LC.cnfServerPort conf of
                       PortNumber num -> fromIntegral num :: Int
                       _              -> undefined
              defaultURI
                  = "http://" ++ host ++ -- FIXME: consider IPv6 address
                    (if port == 80
                     then ""
                     else ':' : show port) ++ "/"
          in
            BaseURI $ fromJust $ parseURI defaultURI


newtype DefaultPage = DefaultPage String deriving (Show, Typeable)
instance SysConfValue DefaultPage where
    confPath _                   = "defaultPage"
    serialize (DefaultPage name) = name
    deserialize name             = Just (DefaultPage name)
    defaultValue _               = DefaultPage "MainPage"


newtype StyleSheet = StyleSheet String deriving (Show, Typeable)
instance SysConfValue StyleSheet where
    confPath _                  = "styleSheet"
    serialize (StyleSheet name) = name
    deserialize name            = Just (StyleSheet name)
    defaultValue _              = StyleSheet "StyleSheet/Default"


newtype Languages = Languages (Map LanguageTag LanguageName) deriving (Show, Typeable)
instance SysConfValue Languages where
    confPath _                  = "languages"
    serialize (Languages langs) = serializeStringPairs (M.toList langs)
    deserialize langs           = fmap (Languages . M.fromList) (deserializeStringPairs langs)
    defaultValue _         
        = 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"  )
                                 ]