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

module Yam.Servant(
    App
  , ServantWrapException(..)
  , API(..)
  , MkApplication
  , ApiToApplication
  , emptyApi
  , emptyApplication
  , mkServe
  , toAPI
  , addApi
  , startSimpleJob
  , startMain
  , InitializeYamContext
  , DataSourceProviders
  , MigrateSQL
  , LoadYamJobs
  ) where

import           Yam.App
import           Yam.Job
import           Yam.Logger
import           Yam.Transaction.Sqlite

import           Control.Exception
    ( SomeException
    , catch
    , fromException
    )
import           Control.Lens                      hiding (Context)
import           Data.Swagger                      hiding
    ( Header
    , HeaderName
    , port
    )
import qualified Data.Text                         as T
import           Data.Typeable                     (cast)
import           Network.HTTP.Types.Status
import           Network.Wai
import           Network.Wai.Handler.Warp
import           Network.Wai.Middleware.AddHeaders (addHeaders)
import           Servant
import           Servant.Server.Internal           (responseServantErr)
import           Servant.Swagger
import           Servant.Swagger.UI
import           Servant.Utils.Enter

type App = AppM Handler

data ServantWrapException = forall e. Exception e => Wrap ServantErr e

instance Show ServantWrapException where
  show (Wrap _ e) = show e
instance Exception ServantWrapException

exceptionHandler ::(MonadIO m) => (Text -> m ())
                               -> (m ResponseReceived -> IO ResponseReceived)
                               -> SomeException
                               -> Application
exceptionHandler log run e _ resH = run $ do
  log    $ showText e
  liftIO $ resH $ responseServantErr $ go e
  where go :: SomeException -> ServantErr
        go e  = case fromException e :: Maybe ServantWrapException of
          Just (Wrap err _) -> err
          _                 -> err400

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

type API api = (Proxy api, YamContext -> Server api)
type MkApplication = YamContext -> Application
type ApiToApplication = forall s. (HasServer s '[YamContext], 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 '[YamContext], HasSwagger api) => API api -> YamContext -> Application
mkServe ps c req resH = do
  enabled   <- evalPropOrDefault True     c "swagger.enable"
  swaggertp <- evalPropOrDefault Jensoleg c "swagger.type"
  if enabled
    then go (swagger swaggertp ps) c req resH
    else go ps                     c req resH
  where go :: (HasServer api '[YamContext]) => API api -> YamContext -> 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 = runReaderTNat c :: ReaderT YamContext Handler :~> Handler
            in (Proxy :: Proxy api, \c -> enter (s c) api)

addApi :: (HasServer api '[YamContext], HasSwagger api, HasServer new '[YamContext], HasSwagger new)
       => API api -> Bool -> API new -> ApiToApplication -> MkApplication
addApi a ok b f c | ok = 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 '[YamContext], HasSwagger api) => SwaggerServiceType -> API api -> API (SwaggerAPI :<|> api)
swagger tp (proxy, api) = (Proxy, \c -> go tp (swaggerDocument proxy) :<|> api c)
  where go Jensoleg = jensolegSwaggerSchemaUIServer
        go _        = swaggerSchemaUIServer

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

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

data Config = Config
  { port :: Int
  , mode :: RunMode
  } deriving Show

instance FromJSON Config where
  parseJSON v = runProp v $ do
      scPort   <- getPropOrDefault (port def) "port"
      scMode   <- getPropOrDefault (mode def) "mode"
      return $ Config scPort scMode

instance Default Config where
  def = Config 8888 Development

type InitializeYamContext = YamContext -> IO YamContext
type DataSourceProviders  = [DataSourceProvider (AppM IO) ()]
type MigrateSQL           = AppM IO ()
type LoadYamJobs          = AppM IO [YamJob]

startSimpleJob :: InitializeYamContext -> MigrateSQL -> LoadYamJobs -> IO ()
startSimpleJob i m l = startMain i [sqliteProvider] m l emptyApplication

showConf :: AppM IO ()
showConf = do
  conf :: Config           <- getPropOrDefault def   ""
  rank :: LogRank          <- getPropOrDefault DEBUG "log.level"
  ds   :: DataSource       <- getPropOrDefault def   "datasource"
  ds2  :: Maybe DataSource <- getProp          "datasource.secondary"
  let title = "---------- Run Alert In " <> showText (mode conf) <> " Mode ----------"
      url   = "http://localhost:"        <> showText (port conf)
  infoLn      title
  infoLn    $ "  LogLevel    : "         <> showText rank
  infoLn    $ "  Database    : "         <> showText (dbtype ds)
  infoLn    $ "  ConnStr     : "         <> showText (conn   ds)
  when (conn ds /= ":memory:") $
    infoLn  $ "  Thread      : "         <> showText (thread ds)
  forM_ ds2 $ \d2 -> do
    infoLn    " Secondary DB : "
    infoLn  $ "  Database    : "         <> showText (dbtype d2)
    infoLn  $ "  ConnStr     : "         <> showText (conn   d2)
    when (conn d2 /= ":memory:") $
     infoLn $ "  Thread      : "         <> showText (thread d2)
  infoLn    $ "  URL         : "         <> url
  swagger <- getPropOrDefault True "swagger.enable"
  unless (swagger && mode conf /= Production) $
    infoLn  $ "  SwaggerURL  : "        <> url <> "/swagger-ui"
  infoLn    $ T.replicate (T.length title) "-"

startMain :: InitializeYamContext
          -> DataSourceProviders
          -> MigrateSQL
          -> LoadYamJobs
          -> MkApplication
          -> IO ()
startMain initialize providers migrateSql jobs application = do
  context <- defaultContext >>= initialize
  runAppM context $ go `finally` cleanContext killJobs
  where go :: AppM IO ()
        go = do showConf
                mds  <- getPropOrDefault def "datasource"
                ds2nd<- getProp              "datasource.secondary"
                conf <- getPropOrDefault def ""
                initDataSource providers mds ds2nd $ do
                  when (migrate mds && mode conf /= Production) migrateSql
                  jobs >>= mapM_ registerJob
                  lockExtenstion
                  context <- ask
                  logger  <- toWaiLogger
                  let pt       = port (conf :: Config)
                      settings = setPort pt
                               $ setLogger logger defaultSettings
                  liftIO  $ runSettings settings
                          $ middleWare  context
                          $ application context