{-# LANGUAGE RecordWildCards           #-}
{-# LANGUAGE TemplateHaskell           #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE TypeOperators             #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE ImpredicativeTypes        #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ViewPatterns              #-}

module Thermoprint.Server
       ( thermoprintServer
       , Config(..), QMConfig(..)
       , withPrinters
       , module Data.Default.Class
       , module Servant.Server.Internal.Enter
       , module Thermoprint.Server.Printer
       , module Thermoprint.Server.Queue
       ) where

import Data.Default.Class
import qualified Config.Dyre as Dyre

import Data.Map (Map)
import qualified Data.Map as Map

import Data.Maybe (maybe)
import Data.Foldable (mapM_, forM_, foldlM)

import Control.Monad.Trans.Resource
import Control.Monad.Trans.Control
import Control.Monad.Trans.Identity
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.IO.Class
import Control.Monad.Morph
import Control.Category
import Prelude hiding (id, (.))

import qualified Control.Monad as M

import Control.Concurrent
import Control.Concurrent.STM
       
import Data.Text (Text)
import qualified Data.Text as T (pack)

import qualified Network.Wai.Handler.Warp as Warp
import Network.Wai (Application)

import Servant.Server (serve)
import Servant.Server.Internal.Enter (enter, (:~>)(..))

import Database.Persist.Sql (runMigrationSilent, ConnectionPool, runSqlPool)


import Thermoprint.API (thermoprintAPI, PrinterId)

import Thermoprint.Server.Database
import Thermoprint.Server.Printer
import Thermoprint.Server.Queue
import qualified Thermoprint.Server.API as API (thermoprintServer)
import Thermoprint.Server.API hiding (thermoprintServer)

-- | Compile-time configuration for 'thermoprintServer'
data Config m = Config { dyreError     :: Maybe String -- ^ Set by 'Dyre' -- sent to log as an error
                       , warpSettings  :: Warp.Settings -- ^ Configure 'Warp's behaviour
                       , printers      :: Map PrinterId Printer
                       , queueManagers :: PrinterId -> QMConfig m
                       }

data QMConfig m = forall t. ( MonadTrans t
                            , MFunctor t
                            , Monad (t STM)
                            , MonadIO (t IO)
                            ) => QMConfig { manager  :: QueueManager t
                                          , collapse :: (t IO) :~> m
                                          }
  
instance MonadIO m => Default (Config m) where
  def = Config { dyreError     = Nothing
               , warpSettings  = Warp.defaultSettings
               , printers      = Map.empty
               , queueManagers = const def
               }

instance MonadIO m => Default (QMConfig m) where
  def = QMConfig idQM $ Nat (liftIO . runIdentityT)

withPrinters :: MonadResource m => Config m -> [(m PrinterMethod, QMConfig m)] -> m (Config m)
-- ^ Add a list of printers to a 'Config'
withPrinters cfg = fmap updateCfg . foldlM mapInsert (Map.mapWithKey (\k a -> (a, queueManagers cfg k)) $ printers cfg)
  where
    mapInsert map (spec, qm) = Map.insert (nextKey map) <$> ((,) <$> printer spec <*> pure qm) <*> pure map
    updateCfg map = let
      printerMap = fmap fst map
      qmMap      = fmap snd map
      qmMap' id
        | (Just qm) <- (Map.lookup id qmMap) = qm
        | otherwise                          = queueManagers cfg id
      in cfg { printers = printerMap, queueManagers = qmMap' }
    nextKey map
      | Map.null map = 0
      | otherwise    = succ . fst $ Map.findMax map

thermoprintServer :: ( MonadLoggerIO m
                     , MonadReader ConnectionPool m
                     , MonadResourceBase m
                     ) => (m :~> IO) -- ^ 'dyre' controls the base of the monad-transformer-stack ('IO') but we let the user specify much of the rest of it (we handle 'ResourceT' ourselves, since we need it to fork properly). Therefore we require a specification of how to collapse the stack.
                     -> ResourceT m (Config (ResourceT m)) -> IO ()
-- ^ Run the server
thermoprintServer io = Dyre.wrapMain $ Dyre.defaultParams
  { Dyre.projectName = "thermoprint-server"
  , Dyre.realMain    = realMain
  , Dyre.showError   = flip (\msg -> fmap (\cfg -> cfg { dyreError = Just msg }))
  }
    where
      realMain cfg = unNat (io . Nat runResourceT) $ do
        Config{..} <- cfg
        maybe (return ()) ($(logErrorS) "Dyre" . T.pack) dyreError
        mapM_ ($(logWarnS) "DB") =<< runSqlPool (runMigrationSilent migrateAll) =<< ask
        forM_ printers $ resourceForkIO . runPrinter
        let
          runQM' (queueManagers -> QMConfig qm nat) printer = unNat nat $ runQM qm printer
        Map.foldrWithKey (\k p a -> resourceForkIO (runQM' k p) >> a) (return ()) printers
        liftIO . Warp.runSettings warpSettings . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat printers