{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

module Main where

import Control.Concurrent.MVar
import Control.Concurrent.STM               (TMVar, putTMVar, newEmptyTMVarIO, atomically)
import System.Win32.SystemServices.Services
import System.Win32.Types
import System.Win32.Registry                (hKEY_LOCAL_MACHINE, regOpenKey, regCloseKey, regQueryValue
                                            ,regQueryValueEx, rEG_DWORD)
import System.IO.Error                      (catchIOError)
import Foreign.Storable                     (peek)
import Foreign.Ptr                          (Ptr, castPtr)
import Foreign.Marshal.Alloc                (alloca)
import Control.Exception                    (bracket)
import System.Log.FastLogger
import Control.Monad.Logger
import qualified Data.Text                  as T

import System.Environment (getArgs)

import Network                              (withSocketsDo)

import Settings
import Supervisor

main :: IO ()
main = do
    args <- getArgs
    gState <- newMVar (1, SERVICE_STATUS WIN32_OWN_PROCESS
                          START_PENDING [] nO_ERROR 0 0 3000)
    mStop <- newEmptyTMVarIO
    if (length args == 1) && (head args == "-d")
        then
            readParamsAndRunSupervisor mStop
        else
            startServiceCtrlDispatcher "NGP_Supervisor" 3000 (svcCtrlHandler mStop gState) $ svcMain mStop gState

hive :: HKEY
hive = hKEY_LOCAL_MACHINE

path :: String
path = "SOFTWARE\\Supervisor"

getConfigPathFromRegistry :: IO FilePath
getConfigPathFromRegistry =
    bracket (regOpenKey hive path) regCloseKey $ \hkey ->
        regQueryValue hkey (Just "ConfigPath")

getClusterConfigPathFromRegistry :: IO FilePath
getClusterConfigPathFromRegistry =
    bracket (regOpenKey hive path) regCloseKey $ \hkey ->
        regQueryValue hkey (Just "ClusterConfigPath")

getLogPathFromRegistry :: IO FilePath
getLogPathFromRegistry =
    bracket (regOpenKey hive path) regCloseKey $ \hkey ->
        regQueryValue hkey (Just "LogPath")

getIsProdLogFromRegistry :: IO Bool
getIsProdLogFromRegistry = fmap (toEnum . fromIntegral) $
    (bracket (regOpenKey hive path) regCloseKey $ \hkey ->
        alloca $ \p_val -> do
            ty <- regQueryValueEx hkey "IsProductionLogLevel" (castPtr p_val) 4
            if ty == rEG_DWORD
                then peekDWORD p_val
                else ioError (userError "Invalid registry value type"))
    `catchIOError` (const $ return 0)
  where
    peekDWORD :: Ptr DWORD -> IO DWORD
    peekDWORD = peek

getWebUIPathFromRegistry :: IO FilePath
getWebUIPathFromRegistry =
    bracket (regOpenKey hive path) regCloseKey $ \hkey ->
        regQueryValue hkey (Just "WebUIPath")

readParamsAndRunSupervisor :: TMVar () -> IO ()
readParamsAndRunSupervisor mStop = do
    settingsPath      <- getConfigPathFromRegistry
    clusterConfigPath <- getClusterConfigPathFromRegistry
    webUIPath         <- getWebUIPathFromRegistry

    logPath <- getLogPathFromRegistry
    productionLog <- getIsProdLogFromRegistry

    loggerSet <- newFileLoggerSet 4096 logPath

    tgetter <- getTimeCache

    let productionFilter = if productionLog
                               then filterLogger (\_ l -> l > LevelDebug)
                               else id

    withSocketsDo $ runLogger tgetter loggerSet $ productionFilter $ do
        settings  <- loadSettingsXml settingsPath
        dynConfig <- loadClusterConfig clusterConfigPath

        $(logInfo) $ T.pack $ show settings
        $(logInfo) $ T.pack $ show dynConfig

        runSupervisor webUIPath
                      settings
                      dynConfig
                      (saveClusterCfg clusterConfigPath)
                      (renewLog loggerSet)
                      (Just mStop)

    rmLoggerSet loggerSet

svcMain :: TMVar () -> MVar (DWORD, SERVICE_STATUS) -> ServiceMainFunction
svcMain mStop gState _ _ h = do
    reportSvcStatus h RUNNING nO_ERROR 0 gState

    readParamsAndRunSupervisor mStop

    reportSvcStatus h STOPPED nO_ERROR 0 gState

reportSvcStatus :: HANDLE -> SERVICE_STATE -> DWORD -> DWORD -> MVar (DWORD, SERVICE_STATUS) -> IO ()
reportSvcStatus hStatus state exitCode waitHint' mState =
    modifyMVar_ mState $ \(checkPoint', svcStatus) -> do
        let state' = nextState (checkPoint', svcStatus
             { win32ExitCode = exitCode
             , waitHint      = waitHint'
             , currentState  = state })
        setServiceStatus hStatus (snd state')
        return state'

nextState :: (DWORD, SERVICE_STATUS) -> (DWORD, SERVICE_STATUS)
nextState (checkPoint', svcStatus) = case currentState svcStatus of
    START_PENDING -> (checkPoint' + 1, svcStatus
        { controlsAccepted = [], checkPoint = checkPoint' + 1 })
    RUNNING -> (checkPoint', svcStatus
        { controlsAccepted = [ACCEPT_STOP], checkPoint = 0 })
    STOPPED -> (checkPoint', svcStatus
        { controlsAccepted = [], checkPoint = 0 })
    _ -> (checkPoint' + 1, svcStatus
        { controlsAccepted = [], checkPoint = checkPoint' + 1 })

svcCtrlHandler :: TMVar () -> MVar (DWORD, SERVICE_STATUS) -> HandlerFunction
svcCtrlHandler mStop mState hStatus STOP = do
    reportSvcStatus hStatus STOP_PENDING nO_ERROR 3000 mState
    atomically $ putTMVar mStop ()
    return True
svcCtrlHandler _ _ _ INTERROGATE = return True
svcCtrlHandler _ _ _ _  = return False