{-# LANGUAGE RankNTypes                    #-}
{-# LANGUAGE FlexibleContexts              #-}
{-# LANGUAGE RecordWildCards               #-}
{-# LANGUAGE OverloadedStrings             #-}
{-# LANGUAGE TemplateHaskell               #-}
{-# LANGUAGE StandaloneDeriving            #-}
{-# LANGUAGE GADTs                         #-}
{-# LANGUAGE ExistentialQuantification     #-}

module Thermoprint.Server.Printer
       ( PrinterMethod(..), Printer(..)
       , printer
       , Queue(..)
       , QueueEntry(..)
       , runPrinter
       , addToQueue
       ) where

import           Thermoprint.API (PrintingError(..), Printout)
import qualified Thermoprint.API as API (JobStatus(..))

import           Thermoprint.Server.Database

import           Database.Persist
import           Database.Persist.Sql

import           Data.Sequence (Seq, ViewR(..), viewr, (<|), (|>))
import qualified Data.Sequence as Seq
import           Data.Map (Map)
import qualified Data.Map as Map

import qualified Data.Text as T (pack)

import           Data.Typeable (Typeable)
import           GHC.Generics (Generic)
import           Control.DeepSeq
import           Data.Default.Class

import           Control.Monad.Trans.Resource
import           Control.Monad.IO.Class
import           Control.Monad.Logger
import           Control.Monad.Reader
import           Control.Monad.Catch (MonadMask)

import           Control.Monad (forever)

import           Control.Concurrent.STM

import           Data.Time.Clock

import           Thermoprint.Server.Queue

newtype PrinterMethod = PM { unPM :: forall m. (MonadResource m, MonadLogger m, MonadMask m) => Printout -> m (Maybe PrintingError) }

data Printer = Printer
  { print :: PrinterMethod
  , queue :: TVar Queue
  }

instance HasQueue Printer where
  extractQueue = queue

printer :: MonadResource m => m PrinterMethod -> m Printer
printer p = Printer <$> p <*> liftIO (newTVarIO def)

atomically' :: MonadIO m => STM a -> m a
atomically' = liftIO . atomically

runPrinter :: ( MonadReader ConnectionPool m
              , MonadLogger m
              , MonadBaseControl IO m
              , MonadResource m
              , MonadMask m
              ) => Printer -> m ()
-- ^ Loop 'forever' pushing entries from the 'Queue' associated to a 'Printer' into its 'print'-method
runPrinter Printer{..} = forever $ do
  entry@(QueueEntry{..}) <- atomically' $ do
    (Queue queuePending Nothing history) <- readTVar queue
    case viewr queuePending of
      EmptyR               -> retry
      (remaining :> current) -> do
        writeTVar queue $!! Queue remaining (Just current) history
        return current
  job <- runSqlPool (get jobId) =<< ask
  case job of
    Nothing  -> do
      atomically' $ modifyTVar' queue (\Queue{..} -> force $ Queue pending Nothing history)
      $(logWarn) "Nonexistent job id in printer queue"
    Just job -> do
      $(logInfo) . T.pack $ "Printing " ++ show (unSqlBackendKey . unJobKey $ jobId)
      printReturn <- (unPM print) (jobContent job) -- We could, at this point, do some exception handling. It was decided that this would be undesirable, because we really don't have any idea what exceptions to catch
      maybe (return ()) ($(logWarn) . T.pack . (("Error while printing " ++ show (unSqlBackendKey . unJobKey $ jobId) ++ ": ") ++) . show) $ printReturn
      atomically' $ modifyTVar' queue (\Queue{..} -> force . Queue pending Nothing $ (entry, printReturn) <| history)

addToQueue :: ( MonadReader ConnectionPool m
              , MonadLogger m
              , MonadResource m
              , MonadBaseControl IO m
              ) => Printout -> Printer -> m JobId
addToQueue printout Printer{..} = do
  jobId <- runSqlPool (insert $ Job printout) =<< ask
  time <- liftIO getCurrentTime
  let
    entry = QueueEntry
      { jobId = jobId
      , created = time
      }
  $(logInfo) . T.pack $ "Queueing " ++ show (unSqlBackendKey . unJobKey $ jobId)
  atomically' $ modifyTVar' queue (\Queue{..} -> force $ Queue (entry <| pending) current history)
  return jobId