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

module Thermoprint.Server
       ( thermoprintServer
       , Config(..)
       , withPrinters
       , module Data.Default.Class
       , module Servant.Server.Internal.Enter
       , module Thermoprint.Server.Printer
       ) 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.Logger
import Control.Monad.Reader
import Control.Monad.IO.Class
import Control.Category
import Prelude hiding (id, (.))

import Control.Concurrent
       
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 qualified Thermoprint.Server.API as API (thermoprintServer)
import Thermoprint.Server.API hiding (thermoprintServer)

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

instance Default Config where
  def = Config { dyreError    = Nothing
               , warpSettings = Warp.defaultSettings
               , printers     = Map.empty
               }

withPrinters :: MonadResource m => Config -> [m PrinterMethod] -> m Config
-- ^ Add a list of printers to a 'Config'
withPrinters cfg pss = (\map -> cfg { printers = map }) <$> foldlM (\map spec -> Map.insert (nextKey map) <$> printer spec <*> pure map) Map.empty pss
  where
    nextKey map
      | Map.null map = 0
      | otherwise    = succ . fst $ Map.findMin 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 the rest of it. Therefore we require a specification of how to enter the stack.
                     -> ResourceT m Config -> 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
        liftIO . Warp.runSettings warpSettings . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat printers