{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE OverloadedLists  #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}

module Thermoprint.ServerSpec (spec) where

import           Test.Hspec
import           Test.Hspec.QuickCheck
import qualified Test.Hspec as Hspec

import           Test.QuickCheck

import           Thermoprint.API
import qualified Thermoprint.Server as S
import           Thermoprint.Client

import           Data.Monoid
import           Data.Function
import           Control.Monad
import           Control.Monad.Logger
import           Control.Monad.Reader
import           Control.Monad.State
import           Control.Monad.Trans.Identity
import           Control.Monad.Trans.Resource
import           Control.Monad.Catch (finally)

import           Database.Persist.Sqlite

import           Control.Concurrent
import           Control.Concurrent.STM
import           Control.Concurrent.STM.TSem
import           Control.Concurrent.Async

import           Control.Exception
import           System.IO.Error

import           System.IO
import           System.IO.Temp

import qualified Data.Text as T

import           Network.Wai.Handler.Warp (defaultSettings, setBeforeMainLoop)
import           Network.HTTP.Types.Status (Status(..))

import qualified Data.Map as Map

deriving instance Eq PrintingError
deriving instance Eq JobStatus
deriving instance Eq PrinterStatus

-- Equality via cotext on Block
instance Eq Block where
  (==) = (==) `on` cotext
-- Structural equality for Chunk 
deriving instance Eq Chunk

data TestPrinter = TestPrinter
  { outputChan :: TMVar Printout
  , failSwitch :: TMVar PrintingError
  }

data TestManager = TestManager
  { manage :: TMVar (S.QueueManager IdentityT)
  , ran :: TSem
  }

data RunningServer = RunningServer
  { thread :: ThreadId
  , termination :: MVar (Either SomeException ())
  , startup :: QSem
  , printer :: TestPrinter
  , manager :: TestManager
  }

setup :: QSem -> IO RunningServer
setup startup = withSystemTempFile "thermoprint.sqlite" $ \fp h -> hClose h >> do
  tPrinter <- TestPrinter <$> newEmptyTMVarIO <*> newEmptyTMVarIO
  tManager <- TestManager <$> newEmptyTMVarIO <*> atomically (newTSem 0)
  term <- newEmptyMVar
  startSem <- newQSem 0
  let
    runSqlite :: ReaderT ConnectionPool (LoggingT IO) a -> IO a
    runSqlite = runStderrLoggingT . filterLogger (const (> LevelDebug)) . withSqlitePool (T.pack fp) 1 . runReaderT

    printers = [ ( pure $ S.PM tPM
                 , S.QMConfig ((join . lift $ takeTMVar (manage tManager) <* signalTSem (ran tManager)) >> return 0) (Nat $ liftIO . runIdentityT)
                 )
               ]

    tPM :: MonadIO m => Printout -> m (Maybe PrintingError)
    tPM printout = liftIO . atomically $ putTMVar (outputChan tPrinter) printout >> tryTakeTMVar (failSwitch tPrinter)
  RunningServer <$> forkFinally (S.thermoprintServer False (Nat runSqlite) $ def' `S.withPrinters` printers) (putMVar term) <*> pure term <*> pure startSem <*> pure tPrinter <*> pure tManager
  where
    def' :: MonadIO m => S.Config m
    def' = S.def { S.warpSettings = setBeforeMainLoop (signalQSem startup) $ defaultSettings }

withSetup :: SpecWith RunningServer -> Spec
withSetup = beforeAll setup' . afterAll teardown
  where
    setup' = do
      startup <- newQSem 0
      r <- setup startup
      waitStartup <- async $ waitQSem startup
      waitTermination <- async . readMVar $ termination r
      wait <- waitEitherCancel waitTermination waitStartup
      case wait of
        Left (Left err) -> throwIO err
        Left (Right _) -> throwIO $ userError "Server thread terminated early"
        Right _ -> return r
    teardown RunningServer{..} = killThread thread >> void (readMVar termination)

spec :: Spec
spec = withSetup $ do
  it "Reports initial server state" $ \RunningServer{..} -> do
    printers                     `shouldReturn` [(0, Available)]
    jobs Nothing Nothing Nothing `shouldReturn` []
    drafts                       `shouldReturn` []
  it "Reports printing errors" $ \RunningServer{..} -> do
    let
      err = IOError "test"
    atomically $ putTMVar (failSwitch printer) err
    jId <- jobCreate Nothing mempty
    atomically . takeTMVar $ outputChan printer
    jobStatus jId `shouldReturn` (Failed err)
  -- it "Queues any Printout" $ \RunningServer{..} -> property $ \p -> do
  --   jId <- jobCreate (Just 0) p
  --   (atomically . takeTMVar . outputChan $ printer) `shouldReturn` p
  it "Reports qualitative queue position" $ \RunningServer{..} -> do
    jids <- replicateM 3 $ jobCreate (Just 0) mempty
    zipWithM_ (\jid ret -> jobStatus jid `shouldReturn` ret) jids
      [ Done
      , Printing 0
      , Queued 0
      ]
    replicateM_ (length jids) . atomically . takeTMVar . outputChan $ printer
    zipWithM_ (\jid ret -> jobStatus jid `shouldReturn` ret) jids (replicate (length jids) Done)
  it "Keeps history" $ \RunningServer{..} -> do
    jobs Nothing Nothing Nothing `shouldNotReturn` []
  it "Runs queue managers" $ \RunningServer{..} -> do
    atomically $ putTMVar (manage manager) S.nullQM
    atomically $ waitTSem (ran manager)
    jobs Nothing Nothing Nothing `shouldReturn` []
  it "Handles drafts" $ \RunningServer{..} -> do
    drafts `shouldReturn` []
    dId <- draftCreate Nothing mempty
    draft dId `shouldReturn` (Nothing, mempty)
    drafts `shouldReturn` [(dId, Nothing :: Maybe DraftTitle)]
    p <- generate arbitrary
    draftReplace dId (Just "Title") p
    draft dId `shouldReturn` (Just "Title", p)
    jId <- draftPrint dId Nothing
    (atomically . takeTMVar $ outputChan printer) `shouldReturn` p
    draftDelete dId
    drafts `shouldReturn` []
    draftReplace dId Nothing p `shouldThrow` is404
  where
    Client{..} = mkClient' $ BaseUrl Http "localhost" 3000 ""
    is404 :: ServantError -> Bool
    is404 e@(FailureResponse {}) = statusCode (responseStatus e) == 404
    is404 _ = False