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

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, ViewL(..), viewl, (<|), (|>))
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 (forever)

import           Control.Concurrent.STM

import           Data.Time.Clock

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

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

-- | Zipper for 'Seq QueueEntry'
data Queue = Queue
  { pending :: Seq QueueEntry -- ^ Pending jobs, closest last
  , current :: Maybe QueueEntry
  , history :: Seq (QueueEntry, Maybe PrintingError) -- ^ Completed jobs, closest first
  }
  deriving (Typeable, Generic, NFData)

instance Default Queue where
  def = Queue
    { pending = Seq.empty
    , current = Nothing
    , history = Seq.empty
    }

data QueueEntry = QueueEntry
  { jobId :: JobId
  , created :: UTCTime
  }
  deriving (Typeable, Generic, NFData)

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
              ) => 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 viewl queuePending of
      EmptyL               -> retry
      (current :< remaining) -> 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 (pending |> entry) current history)
  return jobId