{-# LANGUAGE TypeOperators     #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds         #-}

module Thermoprint.Server.API
       ( ProtoHandler, Handler
       , thermoprintServer
       , handlerNat
       ) where

import           Thermoprint.API hiding (JobId(..), DraftId(..))
import qualified Thermoprint.API as API (JobId(..), DraftId(..))

import           Thermoprint.Server.Printer
import           Thermoprint.Server.Queue
import           Thermoprint.Server.Database
import           Thermoprint.Server.Push

import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import           Data.Map (Map)
import qualified Data.Map as Map

import qualified Data.Text as T

import           Servant hiding (Handler)
import           Servant.Server hiding (Handler)
import           Servant.Utils.Enter
import           Servant.Utils.Links

import           Control.Monad.Logger
import           Control.Monad.Reader
import           Control.Monad.Trans.Resource
import           Control.Monad.Except
import           Control.Monad.IO.Class

import           Control.Concurrent.STM

import           Control.Monad ((<=<), liftM2)
import           Prelude hiding ((.), id, mapM)
import           Control.Category

import           Control.DeepSeq

import           Data.Foldable (toList)
import           Data.Traversable (mapM)
import           Data.Bifunctor
import           Data.Monoid
import           Data.Maybe
import           Data.Function (on)

import           Database.Persist
import           Database.Persist.Sql

import           Data.Conduit (Source, sourceToList, mapOutput)

import           Data.Acquire (with)

import           Control.Monad.Catch (handle, catch)

import           Data.Time

type ProtoHandler = ReaderT HandlerInput (LoggingT (ResourceT IO))
type Handler      = ExceptT ServantErr ProtoHandler

-- ^ Runtime configuration of our handlers
data HandlerInput = HandlerInput { sqlPool  :: ConnectionPool -- ^ How to interact with 'persistent' storage
                                 , printers :: Map PrinterId Printer
                                 , nChan    :: TChan Notification
                                 }

handlerNat :: ( MonadReader ConnectionPool m
              , MonadLoggerIO m
              ) => Map PrinterId Printer -> TChan Notification -> m (Handler :~> ExceptT ServantErr IO)
-- ^ Servant requires its handlers to be 'ExceptT ServantErr IO'
--
-- This generates a 'Nat'ural transformation for squashing the monad-transformer-stack we use in our handlers to the monad 'servant-server' wants
handlerNat printerMap nChan = do
  sqlPool <- ask
  logFunc <- askLoggerIO
  let
    handlerInput = HandlerInput
      { sqlPool  = sqlPool
      , printers = printerMap
      , nChan    = nChan
      }
    protoNat :: ProtoHandler :~> IO
    protoNat = Nat runResourceT . Nat (($ logFunc) . runLoggingT) . runReaderTNat handlerInput
  return $ hoistNat protoNat

thermoprintServer :: ServerT ThermoprintAPI Handler
-- ^ A 'servant-server' for 'ThermoprintAPI'
thermoprintServer = listPrinters
                     :<|> (listJobs :<|> queueJob)
                     :<|> getJob <||> jobStatus <||> abortJob
                     :<|> (listDrafts :<|> addDraft)
                     :<|> updateDraft <||> getDraft <||> deleteDraft <||> printDraft
  where
    --     ::            (a -> b) -> (a -> c) -> (a -> b :<|> c)
    (<||>) :: Monad m => m a      -> m b      -> m (a :<|> b)
    (<||>) = liftM2 (:<|>)
    infixr 9 <||>

notify :: Notification -> Handler ()
notify n = liftIO . atomically =<< flip writeTChan n <$> asks nChan

lookupPrinter :: Maybe PrinterId -> Handler (PrinterId, Printer)
-- ^ Make sure a printer exists
lookupPrinter pId = asks printers >>= maybePrinter' pId
  where
    maybePrinter' Nothing printerMap
      | Map.null printerMap = throwError $ err501 { errBody = "No printers available" }
      | otherwise = return $ Map.findMin printerMap
    maybePrinter' (Just pId) printerMap
      | Just printer <- Map.lookup pId printerMap = return (pId, printer)
      | otherwise = throwError $ err404 { errBody = "No such printer" }

queue' :: MonadIO m => Printer -> m Queue
-- ^ Call 'queue' and handle concurrency
queue' = fmap force . liftIO . readTVarIO . queue

extractJobs :: (PrinterId, Queue) -> Seq (API.JobId, UTCTime, JobStatus)
-- ^ Get an API-compatible list of all jobs from a 'Printer' 'Queue'
extractJobs (pId, Queue pending current history) = mconcat [ fmap (\e -> (castId $ jobId e, created e, Queued pId)) pending
                                                           , maybe Seq.empty Seq.singleton $ fmap (\e -> (castId $ jobId e, created e, Printing pId)) current
                                                           , fmap (\(e, s) -> (castId $ jobId e, created e, maybe Done Failed $ s)) history
                                                           ]

listPrinters :: Handler (Map PrinterId PrinterStatus)
listPrinters = fmap toStatus <$> (mapM (liftIO . readTVarIO . queue) . printers =<< ask)
  where
    toStatus (Queue _ Nothing   _) = Available
    toStatus (Queue _ (Just id) _) = Busy . castId $ jobId id

queueJob :: Maybe PrinterId -> Printout -> Handler API.JobId
queueJob pId printout = lift . fmap castId . withReaderT sqlPool . addToQueue printout . snd =<< lookupPrinter pId

printerStatus :: PrinterId -> Handler PrinterStatus
printerStatus = fmap queueToStatus . queue' . snd <=< lookupPrinter . Just
  where
    queueToStatus (Queue _ Nothing   _) = Available
    queueToStatus (Queue _ (Just c) _) = Busy . castId $ jobId c

listJobs :: Maybe PrinterId
         -> Maybe (Range API.JobId) -> Maybe (Range UTCTime)
         -> Handler (Seq (API.JobId, UTCTime, JobStatus))
listJobs Nothing idR timeR = fmap mconcat . mapM (\pId -> listJobs (Just pId) idR timeR) =<< asks (Map.keys . printers)
listJobs pId     idR timeR = fmap (filterJobs . extractJobs) . (\(a, b) -> (,) a <$> queue' b) =<< lookupPrinter pId
  where
    filterJobs = Seq.filter (\(id, time, _) -> and ([ maybe True (`contains` id) idR
                                                    , maybe True (`contains` time) timeR
                                                    ] :: [Bool])
                            )

getJob :: API.JobId -> Handler Printout
getJob jobId = fmap jobContent . maybe (throwError err404) return =<< runSqlPool (get $ castId jobId) =<< asks sqlPool

jobStatus :: API.JobId -> Handler JobStatus
jobStatus jobId = maybe (throwError err404) return . lookup jobId . map (\(id, _, st) -> (id, st)) . toList =<< listJobs Nothing Nothing Nothing

abortJob :: API.JobId -> Handler ()
abortJob needle = do
  printerIds <- asks (Map.keys . printers)
  found <- fmap or . forM printerIds $ \pId -> do
    (pId', p) <- lookupPrinter $ Just pId
    found <- liftIO . atomically $ do
      current@(Queue pending _ _) <- readTVar $ queue p
      let filtered = Seq.filter ((/= castId needle) . jobId) pending
      writeTVar (queue p) $ current { pending = filtered }
      return . not $ ((==) `on` length) pending filtered
    when found $ do
      $(logInfo) $ "Removed job #" <> (T.pack $ show (castId needle :: Integer)) <> " from " <> (T.pack . show $ pId')
      notify $ safeLink thermoprintAPI (Proxy :: Proxy ("jobs" :> Get '[JSON] (Seq (API.JobId, UTCTime, JobStatus))))
    return found
  when (not found) $ throwError err404

listDrafts :: Handler (Map API.DraftId (Maybe DraftTitle))
listDrafts = asks sqlPool >>= runSqlPool (selectSourceRes [] []) >>= flip with toMap
  where
    toMap source = fmap Map.fromList . sourceToList $ (\(Entity key (Draft title _)) -> (castId key, title)) `mapOutput` source

addDraft :: Maybe DraftTitle -> Printout -> Handler API.DraftId
addDraft title content = do
  id <- fmap castId . runSqlPool (insert $ Draft title content) =<< asks sqlPool
  $(logInfo) $ "Added draft #" <> (T.pack $ show (castId id :: Integer)) <> " (" <> (T.pack $ show title) <> ")"
  notify $ safeLink thermoprintAPI (Proxy :: Proxy ("drafts" :> Get '[JSON] (Map API.DraftId (Maybe DraftTitle))))
  return id

updateDraft :: API.DraftId -> Maybe DraftTitle -> Printout -> Handler ()
updateDraft draftId title content = handle (\(KeyNotFound _) -> throwError $ err404) $ do
  void . runSqlPool (updateGet (castId draftId) [ DraftTitle =. title, DraftContent =. content ]) =<< asks sqlPool
  $(logInfo) $ "Updated draft #" <> (T.pack $ show (castId draftId :: Integer))
  notify $ safeLink thermoprintAPI (Proxy :: Proxy ("draft" :> Capture "draftId" API.DraftId :> Get '[JSON] (Maybe DraftTitle, Printout))) $ draftId

getDraft :: API.DraftId -> Handler (Maybe DraftTitle, Printout)
getDraft draftId = fmap (\(Draft title content) -> (title, content)) . maybe (throwError err404) return =<< runSqlPool (get $ castId draftId) =<< asks sqlPool

deleteDraft :: API.DraftId -> Handler ()
deleteDraft draftId = do
  runSqlPool (delete $ (castId draftId :: Key Draft)) =<< asks sqlPool
  $(logInfo) $ "Made sure draft #" <> (T.pack $ show (castId draftId :: Integer)) <> " is Deleted"
  notify $ safeLink thermoprintAPI (Proxy :: Proxy ("drafts" :> Get '[JSON] (Map API.DraftId (Maybe DraftTitle))))

printDraft :: API.DraftId -> Maybe PrinterId -> Handler API.JobId
printDraft draftId printerId = (\(Draft _ content) -> queueJob printerId content) =<< maybe (throwError err404) return =<< runSqlPool (get $ castId draftId) =<< asks sqlPool