{-# LANGUAGE
    DeriveDataTypeable
  , OverloadedStrings
  , ScopedTypeVariables
  , UnicodeSyntax
  #-}
module Rakka.SystemConfig
    ( SystemConfig
    , SysConfValue(..)

    , mkSystemConfig -- private

    , getSysConf
    , getSysConfA

    , setSysConf
    , setSysConfA

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

    , serializeTextPairs
    , deserializeTextPairs
    , serializeMap
    , deserializeMap
    )
    where
import Control.Applicative
import           Codec.Binary.UTF8.String
import           Control.Arrow.ArrowIO
import Control.Arrow.Unicode
import           Control.Concurrent.STM
import           Control.Monad
import           Control.Monad.Trans
import Control.Monad.Unicode
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy  as L
import qualified Data.CaseInsensitive as CI
import           Data.Dynamic
import           Data.Map (Map)
import qualified Data.Map as M
import           Data.Maybe
import Data.Monoid.Unicode
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import           GHC.Conc (unsafeIOToSTM)
import           Network.BSD
import qualified Network.HTTP.Lucu.Config as LC
import           Network.HTTP.Lucu hiding (Config)
import           Network.URI hiding (path)
import Prelude.Unicode
import           Rakka.Page
import           Rakka.Utils
import           Subversion.FileSystem
import           Subversion.FileSystem.Revision
import           Subversion.FileSystem.Root
import           Subversion.FileSystem.Transaction
import           Subversion.Repository
import           Subversion.Types
import           System.FilePath.Posix
import System.IO.Unsafe
import           System.Log.Logger

logger :: String
logger = "Rakka.SystemConfig"


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

class (Typeable α, Show α, Eq α) ⇒ SysConfValue α where
    confPath     ∷ α → FilePath
    serialize    ∷ α → Text
    deserialize  ∷ Text → Maybe α
    defaultValue ∷ SystemConfig → α

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

getSysConf ∷ ∀m a. (MonadIO m, SysConfValue a) ⇒ SystemConfig → m a
getSysConf sc
    = liftIO $ atomically $
      do cache ← readTVar (scCache sc)
         let path = confPath ((⊥) ∷ a)
         case M.lookup path cache of
           Just val → pure ∘ fromJust $ fromDynamic val
           Nothing  → do val ← unsafeIOToSTM (getSysConf' sc)
                         writeTVar (scCache sc) (M.insert path (toDyn val) cache)
                         return val

getSysConf' ∷ ∀α. SysConfValue α ⇒ SystemConfig → IO α
getSysConf' sc
    = do let path = fromConfPath $ confPath ((⊥) ∷ α)
         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 $ T.pack $ chomp $ decode $ L.unpack str
                        False
                            → return Nothing
         case value of
           Just str
               → case deserialize str of
                   Just val
                       → debugM logger ("Got a config value at `" ⊕ path ⊕ "': " ⊕ show val) ≫
                         return val
                   Nothing
                       → fail ("Got an invalid config value at `" ⊕ path ⊕ "': " ⊕ show str)
           Nothing
               → do let val = defaultValue sc
                    debugM logger ("Got no config value at `" ⊕ path ⊕ "'. Defaulting to " ⊕ show val)
                    return val

setSysConf :: forall m a. (MonadIO m, SysConfValue a) => SystemConfig -> String -> a -> m StatusCode
setSysConf sc userID value
    = liftIO $
      do let path = confPath (undefined :: a)

         current <- getSysConf sc
	 if current == value
	    then return NotModified
	    else do atomically $ do cache <- readTVar (scCache sc)
                                    writeTVar (scCache sc) (M.delete path cache)
		    setSysConf' sc userID value


setSysConf' ∷ ∀α. SysConfValue α ⇒ SystemConfig → String → α → IO StatusCode
setSysConf' sc userID value
    = do let path  = fromConfPath $ confPath ((⊥) ∷ α)
	     str   = (L.fromChunks ∘ (:[]) ∘ T.encodeUtf8 $ serialize value) ⊕ "\n"
	     repos = scRepository sc
         fs  ← getRepositoryFS repos
	 rev ← getYoungestRev fs
         ret ← doReposTxn
               repos
               rev
               userID
               (Just "Automatic commit by Rakka for systemConfig update")
               $ do exists ← isFile path
                    unless exists
                        $ createValueEntry path
                    applyTextLBS path Nothing str
	 case ret of
	   Left  _ → return Conflict
	   Right _ → do debugM logger ("Set a config value at `" ⊕ path ⊕ "': " ⊕ show value)
                        return Created
    where
    createValueEntry ∷ FilePath → Txn ()
    createValueEntry path
        = do createParentDirectories path
             makeFile path

    createParentDirectories ∷ FilePath → Txn ()
    createParentDirectories path
        = do let parentPath = takeDirectory path
             kind ← checkPath parentPath
             case kind of
               NoNode   → createParentDirectories parentPath ≫
                          makeDirectory parentPath
               FileNode → fail ("createParentDirectories: already exists a file: " ⊕ parentPath)
               DirNode  → return ()

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


setSysConfA :: (ArrowIO a, SysConfValue c) => SystemConfig -> String -> a c StatusCode
setSysConfA = (arrIO .) . setSysConf


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

serializeTextPairs ∷ [(Text, Text)] → Text
serializeTextPairs = T.intercalate "\n" ∘ (serializePair' <$>)
    where
      serializePair' ∷ (Text, Text) → Text
      serializePair' (a, b) = a ⊕ " " ⊕ b

serializeMap ∷ (k → Text) → (v → Text) → Map k v → Text
serializeMap f g = serializeTextPairs ∘ ((f ⁂ g) <$>) ∘ M.toList

deserializeTextPairs ∷ Text → Maybe [(Text, Text)]
deserializeTextPairs = mapM deserializePair' ∘ T.lines
    where
      deserializePair' ∷ Text → Maybe (Text, Text)
      deserializePair' s = case T.breakOn " " s of
                             (a, b)
                                 | (¬) (T.null b) → Just (a, T.tail b)
                             _                    → Nothing

deserializeMap ∷ Ord k ⇒ (Text → k) → (Text → v) → Text → Maybe (Map k v)
deserializeMap f g = (M.fromList ∘ ((f ⁂ g) <$>) <$>) ∘ deserializeTextPairs

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

newtype BaseURI = BaseURI URI deriving (Show, Typeable, Eq)
instance SysConfValue BaseURI where
    confPath _              = "baseURI"
    serialize (BaseURI uri) = T.pack $ uriToString id uri ""
    deserialize uri         = fmap BaseURI
                              $ do parsed ← parseURI (T.unpack uri)
                                   when (uriPath parsed        ≡ "" ) mzero
                                   when (last (uriPath parsed) ≠ '/') mzero
                                   when (uriQuery parsed       ≠ "" ) mzero
                                   when (uriFragment parsed    ≠ "" ) mzero
                                   return parsed
    defaultValue sc
        = let conf = scLucuConf sc
              host = C8.unpack $ LC.cnfServerHost conf
              port = unsafePerformIO $
                     do ent <- getServiceByName (LC.cnfServerPort conf) "tcp"
                        return (servicePort ent)
              -- FIXME: There should be a way to change configurations
              -- without web interface nor direct repository
              -- modification.
              defaultURI
                  = "http://" ++ host ++
                    (if port == 80
                     then ""
                     else ':' : show port) ++ "/"
          in
            BaseURI $ fromJust $ parseURI defaultURI

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

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

newtype Languages = Languages (Map LanguageTag LanguageName) deriving (Show, Typeable, Eq)
instance SysConfValue Languages where
    confPath _                  = "languages"
    serialize (Languages langs) = serializeMap CI.foldedCase id langs
    deserialize                 = (Languages <$>) ∘ deserializeMap CI.mk id
    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"  )
                                 ]


newtype GlobalLock = GlobalLock Bool deriving (Show, Typeable, Eq)
instance SysConfValue GlobalLock where
    confPath _      = "globalLock"
    serialize (GlobalLock isLocked)
        | isLocked  = "*"
        | otherwise = ""
    deserialize "*" = Just (GlobalLock True)
    deserialize ""  = Just (GlobalLock False)
    deserialize _   = Nothing
    defaultValue _  = GlobalLock False