{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}

module Service(
    startMain
  , API
  , MaybeAPI
  , toAPI
  , addApi
  , MkApplication
  , emptyApi
  , emptyApplication
  , mkServe
  , loadProps
  , ServiceConfig(..)
  , RunMode(..)
  , HasSwagger
  , enable
  ) where

import           Base

import           Control.Exception                 hiding (Handler)
import           Control.Lens                      hiding (Context)
import           Control.Monad.Trans.State         (StateT, gets, modify')
import           Data.Swagger                      hiding (Header, HeaderName)
import qualified Data.Text                         as T
import           Network.Wai
import           Network.Wai.Handler.Warp
import           Network.Wai.Middleware.AddHeaders (addHeaders)
import           Servant
import           Servant.Swagger
import           Servant.Swagger.UI
import           Servant.Utils.Enter

type API api = (Proxy api, BaseContext -> Server api)
type MaybeAPI api = (Text, Bool, API api)
type MkApplication = BaseContext -> Application
type ApiToApplication = forall s. (HasServer s '[BaseContext], HasSwagger s) => API s -> MkApplication
type SwaggerAPI = SwaggerSchemaUI "swagger-ui" "swagger.json"

emptyApi :: API EmptyAPI
emptyApi = (Proxy, undefined)

emptyApplication :: MkApplication
emptyApplication = mkServe emptyApi

mkServe :: (HasServer api '[BaseContext], HasSwagger api) => API api -> BaseContext -> Application
mkServe ps c | isSwaggerOn c = go (swagger ps) c
             | otherwise     = go ps c
             where isSwaggerOn c = evalPropOrDefault True c "swagger.enable" && evalProp c "mode" /= Just Production
                   go :: (HasServer api '[BaseContext]) => API api -> BaseContext -> Application
                   go (p,s)    c = serveWithContext p (c :. EmptyContext) $ s c

toAPI :: (Enter (ServerT api App) App Handler (Server api)) => ServerT api App -> API api
toAPI api = let s c = evalStateTLNat c :: StateT BaseContext Handler :~> Handler
            in (Proxy :: Proxy api, \c -> enter (s c) api)

addApi :: (HasServer api '[BaseContext], HasSwagger api, HasServer new '[BaseContext], HasSwagger new)
       => API api -> MaybeAPI new -> ApiToApplication -> MkApplication
addApi a (key, def, b) f c | evalPropOrDefault def c key = f (a `ap` b) c
                           | otherwise = f a c
                           where ap :: API a -> API b -> API (a :<|> b)
                                 ap (_,a) (_,b) = (Proxy, \c -> a c:<|>b c)

data SwaggerServiceType = Default | Jensoleg

instance FromJSON SwaggerServiceType where
  parseJSON v = go <$> parseJSON v
    where go :: Text -> SwaggerServiceType
          go "default" = Default
          go _         = Jensoleg

swagger :: (HasServer api '[BaseContext], HasSwagger api) => API api -> API (SwaggerAPI :<|> api)
swagger (proxy, api) = (Proxy, \c -> selectSwagger c (swaggerDocument proxy) :<|> api c)
  where selectSwagger c = go $ evalPropOrDefault Jensoleg c "swagger.type"
        go Jensoleg = jensolegSwaggerSchemaUIServer
        go _        = swaggerSchemaUIServer

swaggerDocument :: HasSwagger api => Proxy api -> Swagger
swaggerDocument proxy = toSwagger proxy
                & info.title       .~ "Corn API"
                & info.version     .~ "2017.6"
                & info.contact     ?~ Contact (Just "Daniel YU") Nothing (Just "i@icymint.me")
                & info.description ?~ "This is an API for Corn Project"

applicationInfo :: HasServer api '[BaseContext] => Proxy api -> BaseContext -> Text
applicationInfo proxy = layoutWithContext proxy . (:. EmptyContext)

initLogger :: BaseContext -> IO BaseContext
initLogger context = do
  mayLogFile <- runAppM context (getProp "log.file")
  case mayLogFile of
    Just file -> do
      newLogger <- fileLog file
      return context {baseLogger = newLogger}
    Nothing   -> return context

loadProps :: BaseContext -> IO BaseContext
loadProps context = do
  let showLog :: IO PropertySource -> IO PropertySource
      showLog a = do
        src@(f,_) <- a
        runAppM context $ debugLn $ "Load Config " <> f <> " .."
        return src
      showLog' a = do
        may <- a
        case may of
          Just a  -> void $ showLog $ return a
          Nothing -> return ()
        return may
  cmdSource@(_, v1) <- showLog loadCommandLineArgs
  c1  <- runProp v1 $ getProp "config"
  envSource@(_, v2) <- showLog loadEnv
  c2  <- runProp v2 $ getProp "config"
  cornSource        <- showLog' $ maybe (tryLoadYaml "corn.yml") (fmap Just . loadYaml) $ selectMaybe [c1,c2]
  let baseSource@(_,bs) = mergePropertySource $ catMaybes [Just cmdSource, Just envSource, cornSource]
  configs   <- runProp bs $ getPropOrDefault [] "configs"
  addtional <- mapM (showLog . loadYaml) configs
  return context {basePropSource = mergePropertySource (baseSource:addtional)}

startMain :: (BaseContext -> IO BaseContext)
          -> IODatabaseRunner
          -> AppM IO [AppMJob]
          -> (ServiceConfig -> AppM IO ())
          -> (BaseContext -> Application)
          -> AppM IO ()
          -> (AppM IO () -> AppM IO ())
          -> IO ()
startMain loadProps dbRunner loadJobs initialize application migrateSql withInData= do
  context <- defaultBaseContext >>= loadProps >>= initLogger
  runAppM context $ do
    sc <- getPropOrDefault def ""
    let config      = _dataSource sc
        port        = _httpPort   sc
        rank        = _logRank    sc
        mode        = _runMode    sc
        update  c   = c { baseLogger     = setRank (baseLogger c) }
        setRank c   = c { logContextRank = rank }
        setLogRank  = modify' update
        title       = "---------- Run Corn In " <> showText mode <> " Mode ----------"
        url         = "http://localhost:"       <> showText port
        showConf    = do
          infoLn      title
          infoLn    $ "  LogLevel    : "        <> showText rank
          infoLn    $ "  Database    : "        <> showText (_dataSourceType config)
          infoLn    $ "  ConnStr     : "        <> showText (_dataSourceConn config)
          when (_dataSourceConn config /= ":memory:") $
            infoLn  $ "  Thread      : "        <> showText (_dataSourceThread config)
          infoLn    $ "  URL         : "        <> url
          swagger <- getPropOrDefault True "swagger.enable"
          unless (swagger && mode /= Production) $
            infoLn  $ "  SwaggerURL  : "        <> url <> "/swagger-ui"
          infoLn    $ T.replicate (T.length title) "-"
        action      = do
          showConf
          initialize sc
          let isMigrate = _runMode sc /= Production && _dataSourceMigrate config
          when isMigrate migrateSql
          logger  <- waiLogger
          let settings = setPort   port
                       $ setLogger logger
                         defaultSettings
          jobs    <- loadJobs
          withJob jobs $
            withInData $ do
            lockExtenstion  -- Lock Context Extensions
            context <- gets id
            liftIO     $ runSettings settings
                       $ middleWare  context
                       $ application context
    setLogRank >> runInDatabase config dbRunner action


data RunMode = Production
             | Development
             deriving (Eq,Show)

instance FromJSON RunMode where
  parseJSON v = go <$> parseJSON v
    where go :: Text -> RunMode
          go "production"  = Production
          go "development" = Development
          go _             = _runMode def

data ServiceConfig = ServiceConfig
  { _dataSource :: DataSourceConfig
  , _logRank    :: LogRank
  , _httpPort   :: Int
  , _runMode    :: RunMode
  } deriving Show

instance FromJSON ServiceConfig where
  parseJSON v = runProp v $ do
      scDs     <- getPropOrDefault def  "datasource"
      scLevel  <- getPropOrDefault (_logRank  def) "log.level"
      scPort   <- getPropOrDefault (_httpPort def) "port"
      scMode   <- getPropOrDefault (_runMode  def) "mode"
      return $ ServiceConfig scDs scLevel scPort scMode

instance Default ServiceConfig where
  def = ServiceConfig def DEBUG 8888 Development

-- add Correlation-Id and exception convert
middleWare :: BaseContext -> Middleware
middleWare context app req resH = do
  reqId   <- randomHex 8
  let go a = addHeaders [("X-Correlation-Id",cs reqId)] a req resH
      run :: AppM IO a -> IO a
      run  = runAppM context
  run $ withLogName (reqId <> " corn")
      $ liftIO $ go app `catch` (go . exceptionHandler errorLn run)

enable :: FromJSON a => Text -> Bool -> Text -> (Maybe a -> AppM IO ()) -> AppM IO ()
enable keyEnable def key action = do
        enables <- getPropOrDefault def keyEnable
        when enables $ getProp key >>= action
