{-# 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(..)
       , 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

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 JobId'
data Queue = Queue
  { pending :: Seq JobId -- ^ Pending jobs, closest first
  , current :: Maybe JobId
  , history :: Seq (JobId, Maybe PrintingError) -- ^ Completed jobs, closest first
  }
  deriving (Typeable, Generic, NFData)

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

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
  jobId <- atomically' $ do
    (Queue queuePending Nothing history) <- readTVar queue
    case viewl queuePending of
      EmptyL               -> retry
      (jobId :< remaining) -> do
        writeTVar queue $!! Queue remaining (Just jobId) history
        return jobId
  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 $ (jobId, 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
  $(logInfo) . T.pack $ "Queueing " ++ show (unSqlBackendKey . unJobKey $ jobId)
  atomically' $ modifyTVar' queue (\Queue{..} -> force $ Queue (jobId <| pending) current history)
  return jobId