-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Handler.PrintCenter
  ( getPrintDownloadR
  , getPrintCenterR, postPrintCenterR
  , getPrintSendR  , postPrintSendR
  , getPrintAckR   , postPrintAckR
  , getPrintAckDirectR, postPrintAckDirectR
  , getPrintLogR
  ) where

import Import

import qualified Data.Set as Set
import qualified Data.Map as Map

import Database.Persist.Sql (updateWhereCount)
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH

import Utils.Print

import qualified Data.Aeson  as Aeson
-- import qualified Data.Text as Text
-- import qualified Data.Set  as Set

import Handler.Utils
-- import Handler.Utils.Csv
-- import qualified Data.Csv as Csv
import qualified Data.CaseInsensitive as CI

import Jobs.Queue


-- avoids repetition of local definitions
single :: (k,a) -> Map k a
single = uncurry Map.singleton


data LRQF = LRQF
    { lrqfLetter    :: Text
    , lrqfUser      :: Either UserEmail UserId
    , lrqfSuper     :: Maybe (Either UserEmail UserId)
    , lrqfQuali     :: Entity Qualification
    , lrqfIdent     :: LmsIdent
    , lrqfPin       :: Text
    , lrqfExpiry    :: Maybe Day
    , lrqfReminder  :: Bool
    } deriving (Eq, Generic)

makeRenewalForm :: Maybe LRQF -> Form LRQF
makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateLetterRenewQualificationF $ \html -> do
  -- now_day <- utctDay <$> liftIO getCurrentTime
  flip (renderAForm FormStandard) html $ LRQF
    <$> areq textField                  (fslI MsgPrintLetterType)              (lrqfLetter    <$> tmpl)
    <*> areq (userField False Nothing)  (fslI MsgLmsUser)                      (lrqfUser      <$> tmpl)
    <*> aopt (userField False Nothing)  (fslI MsgTableSupervisor)              (lrqfSuper     <$> tmpl)
    <*> areq qualificationFieldEnt      (fslI MsgQualificationName)            (lrqfQuali     <$> tmpl)
    <*> areq lmsField                   (fslI MsgTableLmsIdent)                (lrqfIdent     <$> tmpl)
    <*> areq textField                  (fslI MsgTableLmsPin)                  (lrqfPin       <$> tmpl)
    <*> aopt dayField                   (fslI MsgLmsQualificationValidUntil)   (lrqfExpiry    <$> tmpl)
    <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant)
                                        (fslI MsgLmsRenewalReminder)           (lrqfReminder  <$> tmpl)
  where
    lmsField = convertField LmsIdent getLmsIdent textField

validateLetterRenewQualificationF :: FormValidator LRQF Handler ()
validateLetterRenewQualificationF = -- do
  -- LRQF{..} <- State.get
  return ()

lrqf2letter :: LRQF -> DB (Entity User, SomeLetter)
lrqf2letter LRQF{..}
  | lrqfLetter == "r" = do
    usr   <-      getUser lrqfUser
    rcvr  <- mapM getUser lrqfSuper
    now   <- liftIO getCurrentTime
    let letter = LetterRenewQualificationF
          { lmsLogin      = lrqfIdent
          , lmsPin        = lrqfPin
          , qualHolderID  = usr ^. _entityKey
          , qualHolderDN  = usr ^. _userDisplayName
          , qualHolderSN  = usr ^. _userSurname
          , qualExpiry    = fromMaybe (utctDay now) lrqfExpiry
          , qualId        = lrqfQuali ^. _entityKey
          , qualName      = lrqfQuali ^. _qualificationName      . _CI
          , qualShort     = lrqfQuali ^. _qualificationShorthand . _CI
          , qualSchool    = lrqfQuali ^. _qualificationSchool
          , qualDuration  = lrqfQuali ^. _qualificationValidDuration
          , isReminder    = lrqfReminder
          }
    return (fromMaybe usr rcvr, SomeLetter letter)
  | lrqfLetter == "e" || lrqfLetter == "E" = do
    rcvr    <- mapM getUser lrqfSuper
    usr     <-      getUser lrqfUser
    usrShrt <- encrypt $ entityKey usr
    usrUuid <- encrypt $ entityKey usr
    urender <- liftHandler getUrlRender
    let letter = LetterExpireQualification
          { leqHolderCFN   = usrShrt
          , leqHolderID    = usr ^. _entityKey
          , leqHolderDN    = usr ^. _userDisplayName
          , leqHolderSN    = usr ^. _userSurname
          , leqExpiry      = lrqfExpiry
          , leqId          = lrqfQuali ^. _entityKey
          , leqName        = lrqfQuali ^. _qualificationName      . _CI
          , leqShort       = lrqfQuali ^. _qualificationShorthand . _CI
          , leqSchool      = lrqfQuali ^. _qualificationSchool
          , leqUrl         = pure . urender $ ForProfileDataR usrUuid
          }
    return (fromMaybe usr rcvr, SomeLetter letter)
  | otherwise = error "Unknown Letter Type encountered. Use 'e' or 'r' only."
  where
    getUser :: Either UserEmail UserId -> DB (Entity User)
    getUser (Right uid) = getEntity404 uid
    getUser (Left mail) = getBy404 $ UniqueEmail mail


data PJTableAction = PJActAcknowledge | PJActReprint
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)

instance Universe PJTableAction
instance Finite PJTableAction
nullaryPathPiece ''PJTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''PJTableAction id

-- Not yet needed, since there is no additional data for now:
data PJTableActionData  = PJActAcknowledgeData | PJActReprintData { ignoreReroute :: Maybe Bool }
  deriving (Eq, Ord, Read, Show, Generic)

type PJTableExpr = (                  E.SqlExpr (Entity PrintJob)
                    `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
                    `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
                    `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Course))
                    `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Qualification))
                  )

queryPrintJob :: PJTableExpr -> E.SqlExpr (Entity PrintJob)
queryPrintJob = $(sqlLOJproj 5 1)

queryRecipient :: PJTableExpr -> E.SqlExpr (Maybe (Entity User))
queryRecipient = $(sqlLOJproj 5 2)

querySender :: PJTableExpr -> E.SqlExpr (Maybe (Entity User))
querySender = $(sqlLOJproj 5 3)

queryCourse :: PJTableExpr -> E.SqlExpr (Maybe (Entity Course))
queryCourse = $(sqlLOJproj 5 4)

queryQualification :: PJTableExpr -> E.SqlExpr (Maybe (Entity Qualification))
queryQualification = $(sqlLOJproj 5 5)

type PJTableData = DBRow (Entity PrintJob, Maybe (Entity User), Maybe (Entity User), Maybe (Entity Course), Maybe (Entity Qualification))

resultPrintJob :: Lens' PJTableData (Entity PrintJob)
resultPrintJob = _dbrOutput . _1

resultRecipient :: Traversal' PJTableData (Entity User)
resultRecipient = _dbrOutput . _2 . _Just

resultSender :: Traversal' PJTableData (Entity User)
resultSender = _dbrOutput . _3 . _Just

resultCourse :: Traversal' PJTableData (Entity Course)
resultCourse = _dbrOutput . _4 . _Just

resultQualification :: Traversal' PJTableData (Entity Qualification)
resultQualification = _dbrOutput . _5 . _Just

pjTableQuery :: PJTableExpr -> E.SqlQuery
  ( E.SqlExpr (Entity PrintJob)
  , E.SqlExpr (Maybe (Entity User))
  , E.SqlExpr (Maybe (Entity User))
  , E.SqlExpr (Maybe (Entity Course))
  , E.SqlExpr (Maybe (Entity Qualification)))
pjTableQuery (printJob `E.LeftOuterJoin` recipient
                       `E.LeftOuterJoin` sender
                       `E.LeftOuterJoin` course
                       `E.LeftOuterJoin` quali    ) = do
  E.on $ printJob E.^. PrintJobRecipient      E.==. recipient E.?. UserId
  E.on $ printJob E.^. PrintJobSender         E.==. sender    E.?. UserId
  E.on $ printJob E.^. PrintJobCourse         E.==. course    E.?. CourseId
  E.on $ printJob E.^. PrintJobQualification  E.==. quali     E.?. QualificationId
  return (printJob, recipient, sender, course, quali)

mkPJTable :: DB (FormResult (PJTableActionData, Set PrintJobId), Widget)
mkPJTable = do
  let
    dbtSQLQuery = pjTableQuery
    dbtRowKey = queryPrintJob >>> (E.^. PrintJobId)
    dbtProj = dbtProjId
    dbtColonnade = mconcat
      [ dbSelect (applying _2) id (return . view (resultPrintJob . _entityKey)) -- condition for dbSelectIf: (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged)
      , sortable (Just "created")      (i18nCell MsgPrintJobCreated)       $ \(   view $ resultPrintJob . _entityVal . _printJobCreated        -> t) ->      dateTimeCell t
      , sortable (Just "acknowledged") (i18nCell MsgPrintJobAcknowledged)  $ \(   view $ resultPrintJob . _entityVal . _printJobAcknowledged   -> t) -> maybeDateTimeCell t
      , sortable (Just "filename")     (i18nCell MsgPrintPDF)  $ \r -> let k = r ^. resultPrintJob . _entityKey
                                                                           t = r ^. resultPrintJob . _entityVal . _printJobFilename
                                                                       in anchorCellM (PrintDownloadR <$> encrypt k) (toWgt t)
      , sortable (Just "apcid")        (i18nCell MsgPrintJobApcAcknowledge)$ \(   view $ resultPrintJob . _entityVal . _printJobApcIdent  -> t) -> textCell t
      , sortable (Just "name")         (i18nCell MsgPrintJobName)          $ \(   view $ resultPrintJob . _entityVal . _printJobName      -> n) -> textCell n
      , sortable (Just "recipient")    (i18nCell MsgPrintRecipient)        $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
      , sortable (Just "sender")       (i18nCell MsgPrintSender)           $ \(preview resultSender    -> u) -> maybeCell u $ cellHasUserLink AdminUserR
      , sortable (Just "course")       (i18nCell MsgPrintCourse)           $ \(preview $ resultCourse        . _entityVal -> c) -> maybeCell c courseCell
      , sortable (Just "qualification")(i18nCell MsgPrintQualification)    $ \(preview $ resultQualification . _entityVal -> q) -> maybeCell q qualificationCell
      , sortable (Just "lmsid")        (i18nCell MsgPrintLmsUser)          $ \(   view $ resultPrintJob . _entityVal . _printJobLmsUser -> l) -> foldMap (textCell . getLmsIdent) l
      ]
    dbtSorting = mconcat
      [ single ("name"         , SortColumn $ queryPrintJob      >>> (E.^. PrintJobName))
      , single ("filename"     , SortColumn $ queryPrintJob      >>> (E.^. PrintJobFilename))
      , single ("created"      , SortColumn $ queryPrintJob      >>> (E.^. PrintJobCreated))
      , single ("acknowledged" , SortColumn $ queryPrintJob      >>> (E.^. PrintJobAcknowledged))
      , single ("apcid"        , SortColumn $ queryPrintJob      >>> (E.^. PrintJobApcIdent))
      , single ("recipient"    , sortUserNameBareM queryRecipient)
      , single ("sender"       , sortUserNameBareM querySender   )
      , single ("course"       , SortColumn $ queryCourse        >>> (E.?. CourseName))
      , single ("qualification", SortColumn $ queryQualification >>> (E.?. QualificationName))
      , single ("lmsid"        , SortColumn $ queryPrintJob      >>> (E.^. PrintJobLmsUser))
      ]
    dbtFilter = mconcat
      [ single ("name"         , FilterColumn . E.mkContainsFilterWithCommaPlus id                $ views (to queryPrintJob)      (E.^. PrintJobName))
      , single ("apcid"        , FilterColumn . E.mkContainsFilterWithComma     id                $ views (to queryPrintJob)      (E.^. PrintJobApcIdent))
      , single ("filename"     , FilterColumn . E.mkContainsFilter                                $ views (to queryPrintJob)      (E.^. PrintJobFilename))
      , single ("created"      , FilterColumn . E.mkDayFilter                                     $ views (to queryPrintJob)      (E.^. PrintJobCreated))
      --, single ("created"      , FilterColumn . E.mkDayBetweenFilter                            $ views (to queryPrintJob)      (E.^. PrintJobCreated))
      , single ("recipient"    , FilterColumn . E.mkContainsFilterWithCommaPlus Just              $ views (to queryRecipient)     (E.?. UserDisplayName))
      , single ("sender"       , FilterColumn . E.mkContainsFilterWithCommaPlus Just              $ views (to querySender)        (E.?. UserDisplayName))
      , single ("course"       , FilterColumn . E.mkContainsFilterWith          (Just . CI.mk)    $ views (to queryCourse)        (E.?. CourseName))
      , single ("qualification", FilterColumn . E.mkContainsFilterWith          (Just . CI.mk)    $ views (to queryQualification) (E.?. QualificationName))
      , single ("lmsid"        , FilterColumn . E.mkContainsFilterWithCommaPlus (Just . LmsIdent) $ views (to queryPrintJob)      (E.^. PrintJobLmsUser))

      , single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged)))
      ]
    dbtFilterUI mPrev = mconcat
      [ prismAForm (singletonFilter "name"         . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintJobName & setTooltip MsgTableFilterCommaPlus)
      , prismAForm (singletonFilter "filename"     . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintJobFilename)
      , prismAForm (singletonFilter "created"      . maybePrism _PathPiece) mPrev $ aopt (hoistField lift  dayField)                        (fslI MsgPrintJobCreated)
      --, prismAForm (singletonFilter "created"      . maybePrism _PathPiece) mPrev ((,) <$> aopt (hoistField lift  dayField)                        (fslI MsgPrintJobCreated)
      --                                                                                  <*> aopt (hoistField lift  dayField)                        (fslI MsgPrintJobCreated)
      --                                                                          )
      , prismAForm (singletonFilter "recipient"    . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus)
      , prismAForm (singletonFilter "sender"       . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintSender    & setTooltip MsgTableFilterCommaPlus)
      , prismAForm (singletonFilter "course"       . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintCourse)
      , prismAForm (singletonFilter "qualification". maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintQualification)
      , prismAForm (singletonFilter "lmsid"        . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintLmsUser & setTooltip MsgTableFilterCommaPlus)
      , prismAForm (singletonFilter "apcid"        . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintJobApcAcknowledge & setTooltip MsgTableFilterComma)
      , prismAForm (singletonFilter "acknowledged" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgPrintJobAcknowledged)
      ]
    dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
    dbtIdent :: Text
    dbtIdent = "print-job"
    dbtCsvEncode = noCsvEncode
    dbtCsvDecode = Nothing
    dbtExtraReps = []
    dbtParams = DBParamsForm
      { dbParamsFormMethod = POST
      , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
      , dbParamsFormAttrs  = []
      , dbParamsFormSubmit = FormSubmit
      , dbParamsFormAdditional
          = let acts :: Map PJTableAction (AForm Handler PJTableActionData)
                acts = mconcat
                  [ singletonMap PJActAcknowledge $ pure PJActAcknowledgeData
                  , singletonMap PJActReprint     $ PJActReprintData
                      <$> aopt checkBoxField (fslI MsgPJActReprintIgnoreReroute) Nothing
                  ]
             in renderAForm FormStandard
               $  (, mempty) . First . Just
              <$> multiActionA acts (fslI MsgTableAction) Nothing
      , dbParamsFormEvaluate = liftHandler . runFormPost
      , dbParamsFormResult   = id
      , dbParamsFormIdent    = def
      }
    postprocess :: FormResult (First PJTableActionData, DBFormResult PrintJobId Bool PJTableData)
                -> FormResult (      PJTableActionData, Set PrintJobId)
    postprocess inp = do
        (First (Just act), jobMap) <- inp
        let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
        return (act, jobSet)
    psValidator = def & defaultSorting [SortDescBy "acknowledged", SortDescBy "created"]
                      -- & defaultFilter (singletonMap "acknowledged" [toPathPiece False]) -- TODO: sorting with Nothing restores this filter
  over _1 postprocess <$> dbTable psValidator DBTable{..}

getPrintCenterR,  postPrintCenterR :: Handler Html
getPrintCenterR = postPrintCenterR
postPrintCenterR = do
  (pjRes, pjTable) <- runDB mkPJTable

  formResult pjRes $ \case
    (PJActAcknowledgeData, Set.toList -> pjIds) -> do
      now <- liftIO getCurrentTime
      num <- runDB $ updateWhereCount  [PrintJobAcknowledged ==. Nothing, PrintJobId <-. pjIds] [PrintJobAcknowledged =. Just now]
      addMessageI Success $ MsgPrintJobAcknowledge num
      reloadKeepGetParams PrintCenterR
    (PJActReprintData{ignoreReroute}, Set.toList -> pjIds) -> do
      let countOk = either (const $ Sum 0) (const $ Sum 1)
      oks <- runDB $ forM pjIds $ fmap countOk . reprintPDF (fromMaybe False ignoreReroute)
      let nr_oks = getSum $ mconcat oks
          nr_tot = length pjIds
          mstat  = bool Warning Success $ nr_oks == nr_tot
      addMessageI mstat $ MsgPrintJobReprint nr_oks nr_tot
      reloadKeepGetParams PrintCenterR
  siteConf <- getYesod
  let lprConf = siteConf ^. _appLprConf
      reroute = siteConf ^. _appMailRerouteTo
      lprWgt  = [whamlet|
          LPR Konfiguration ist #{lprQueue lprConf}@#{lprHost lprConf}:#{lprPort lprConf}
          <div>
            $maybe _ <- reroute
              Mail-reroute-to ist gesetzt, somit werden alle lpr Kommandos unterdrückt!
        |]
  siteLayoutMsg MsgMenuApc $ do
    setTitleI MsgMenuApc
    $(widgetFile "print-center") --  i18nWidgetFile? Currently no text contained; displays just the table only


getPrintSendR, postPrintSendR :: Handler Html
getPrintSendR = postPrintSendR
postPrintSendR = do
  usr  <- requireAuth -- to determine language and recipient for test
  mbQual <- runDB $ selectFirst [] [Asc QualificationAvsLicence, Asc QualificationShorthand]
  now <- liftIO getCurrentTime
  let nowaday = utctDay now
      uid = usr ^. _entityKey
      mkLetter qual = LRQF
        { lrqfLetter    = "r"
        , lrqfUser      = Right uid
        , lrqfSuper     = Nothing
        , lrqfQuali     = qual
        , lrqfIdent     = LmsIdent  "stuvwxyz"
        , lrqfPin       =           "76543210"
        , lrqfExpiry    = Just $ succ nowaday
        , lrqfReminder  = False
        }
      def_lrqf = mkLetter <$> mbQual

  ((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm def_lrqf
  let procFormSend lrqf = case lrqfLetter lrqf of
        "E" -> (runDB (lrqf2letter lrqf) >>= printHtml (Just uid)) >>= \case
            Right html -> sendResponse $ toTypedContent html
            Left err -> do
              let msg = "PDF printing failed with error: " <> err
              $logErrorS "LPR" msg
              addMessage Error $ toHtml msg
              pure ()
        _ -> do
            ok <- (runDB (lrqf2letter lrqf) >>= printLetter (Just uid)) >>= \case
              Left err -> do
                let msg = "PDF printing failed with error: " <> err
                $logErrorS "LPR" msg
                addMessage Error $ toHtml msg
                pure False
              Right (ok, fpath) -> do
                let response = if null ok then mempty else  " Response: " <> ok
                addMessage Success $ toHtml $ "Druckauftrag angelegt: " <> pack fpath <> response
                pure True
            when ok $ redirect PrintCenterR
  formResult sendResult procFormSend
  -- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
  siteLayoutMsg MsgPrintManualRenewal $ do
    setTitleI MsgMenuPrintSend
    let sendForm = wrapForm sendWidget def
                    { formEncoding = sendEnctype
                    -- , formAction = Just $ SomeRoute actionUrl
                    }
    $(widgetFile "print-send") -- i18nWidgetFile? Currently no text contained; displays just the form only


getPrintDownloadR :: CryptoUUIDPrintJob -> Handler TypedContent
getPrintDownloadR cupj = do
    pjId <- decrypt cupj
    PrintJob {..} <- runDB $ get404 pjId
    sendByteStringAsFile printJobFilename printJobFile printJobCreated
{- for PrintJobFile :: FileContentReference use this code, however, requires instances
  HasFileReference PrintJob and IsFileReference PrintJob which seemed to complicated... :(
    serveOneFile $ fileQuery .| C.map entityVal
  where
    fileQuery = E.selectSource $ E.from $
      \pj -> do
        -- filter to requested file
        E.where_ (pj E.^. PrintJobId E.==. E.val pjId)
        -- return file entity
        return pj
-}


getPrintAckR,  postPrintAckR :: Day -> Int -> Int -> Handler Html
getPrintAckR = postPrintAckR
postPrintAckR ackDay numAck chksm = do
  ((ackRes, ackWgt), ackEnctype) <- runFormPost (identifyForm FIDPrintAcknowledge buttonForm :: Form ButtonConfirm)
  let ackForm = wrapForm ackWgt def
        { formAction   = Just $ SomeRoute $ PrintAckR ackDay numAck chksm
        , formEncoding = ackEnctype
        , formSubmit   = FormNoSubmit
        }
  formResult ackRes $ \BtnConfirm -> do
    numNew <- runDB $ do
      pjs <- Ex.select $ do
        pj <- Ex.from $ Ex.table @PrintJob
        let pjDay = E.day $ pj Ex.^. PrintJobCreated
        Ex.where_ $  Ex.isNothing (pj Ex.^. PrintJobAcknowledged)
              Ex.&&. (pjDay Ex.==. Ex.val ackDay)
        return $ pj Ex.^. PrintJobId
      let changed = numAck /= length pjs || chksm /= hash (Set.fromList (Ex.unValue <$> pjs))
      if changed
        then return (-1)
        else do
          now <- liftIO getCurrentTime
          E.updateCount $ \pj -> do
            let pjDay = E.day $ pj E.^. PrintJobCreated
            E.set pj [ PrintJobAcknowledged E.=. E.justVal now ]
            E.where_ $ E.isNothing (pj E.^. PrintJobAcknowledged)
                  E.&&. (pjDay E.==. E.val ackDay)
          --  Ex.updateCount $ do
            --  pj <- Ex.from $ Ex.table @PrintJob
            --  let pjDay = E.day $ pj Ex.^. PrintJobCreated
            --  Ex.set pj [ PrintJobAcknowledged Ex.=. Ex.just (Ex.val now) ]
            --  Ex.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged)
                  -- Ex.&&. (pjDay Ex.==. Ex.val ackDay)
    if numNew > 0
      then addMessageI Success $ MsgPrintJobAcknowledge numNew
      else addMessageI Error     MsgPrintJobAcknowledgeFailed
    redirect PrintCenterR
  ackDayText <- formatTime SelFormatDate ackDay
  siteLayoutMsg
    (MsgPrintJobAcknowledgeQuestion numAck ackDayText)
    ackForm

-- no header csv, containing a single column of lms identifiers (logins)
-- instance Csv.FromRecord LmsIdent -- default suffices
-- instance Csv.FromRecord Text where
--   parseRecord v
--     | length v >= 1 = v Csv..! 0
--     | otherwise     = pure "ERROR"

saveApcident :: UTCTime -> Natural -> Text -> JobDB Natural
saveApcident t i apci = insert_ (PrintAcknowledge apci t False) >> return (succ i)


makeAckUploadForm :: Form FileInfo
makeAckUploadForm = renderAForm FormStandard $ fileAFormReq "Acknowledge APC-Ident CSV"

getPrintAckDirectR :: Handler Html
getPrintAckDirectR = do
  (widget, enctype) <- generateFormPost makeAckUploadForm
  siteLayoutMsg MsgMenuPrintAck $ do
    setTitleI MsgMenuPrintAck
    [whamlet|$newline never
      <form method=post enctype=#{enctype}>
        ^{widget}
        <input type=submit>
    |]

postPrintAckDirectR :: Handler Html
postPrintAckDirectR = do
  now <- liftIO getCurrentTime
  (_params, files) <- runRequestBody
  (status, msg) <- case files of
    [(_fhead,file)] -> do
      runDBJobs $ do
        enr <- try $ runConduit $ fileSource file
                -- .| decodeCsvPositional Csv.NoHeader -- decode by separator position
                .| decodeUtf8C      -- no CSV, just convert each line to a single text
                .| linesUnboundedC
                .| foldMC (saveApcident now) 0
        case enr of
          Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error
            $logWarnS "APC" $ "Result upload failed parsing: " <> tshow e
            return (badRequest400, "Error: " <> tshow e)
          Right nr -> do
            let msg = "Success: received " <> tshow nr <> " APC identifiers to be processed later."
            $logInfoS "LMS" msg
            when (nr > 0) $ queueDBJob JobPrintAck
            return (ok200, msg)
    []     -> do
      let msg = "Error: No file received. A file of lms identifiers must be supplied for print job acknowledging."
      $logWarnS "APC" msg
      return (badRequest400, msg)
    _other -> do
      let msg = "Error: Only a single file may be uploaded for print job acknowlegement; all ignored."
      $logErrorS "APC" msg
      return (badRequest400, msg)
  sendResponseStatus status msg -- must be outside of runDB; otherwise transaction is rolled back


getPrintLogR :: Handler Html
getPrintLogR = do
  let
    logDBTable = DBTable{..}
      where
        resultLog :: Lens' (DBRow (TransactionLog, Aeson.Result Transaction)) TransactionLog
        resultLog = _dbrOutput . _1

        resultTrans :: Lens' (DBRow (TransactionLog, Aeson.Result Transaction)) (Aeson.Result Transaction)
        resultTrans = _dbrOutput . _2

        tCell' err c dbr = case view resultTrans dbr of
          (Aeson.Error msg) -> err msg -- should not happen, due to query filter
          (Aeson.Success t) -> c t
        tCellErr = tCell' stringCell
        tCell    = tCell' $ const mempty

        dbtIdent = "lpr-log" :: Text
        dbtSQLQuery l = do
          E.where_ $ E.val "LPR" E.==. l E.^. TransactionLogInfo E.->>. "interface-name"
            -- E.&&. E.val "interface" E.==. l E.^. TransactionLogInfo E.->>. "transaction" -- not necessary
          return l
        dbtRowKey = (E.^. TransactionLogId)
        dbtProj = dbtProjSimple $ \(Entity _ l) -> do
          return (l, Aeson.fromJSON $ transactionLogInfo l)
        dbtColonnade = dbColonnade $ mconcat
          [ sortable (Just "time")    (i18nCell MsgSystemMessageTimestamp) $ \(view $ resultLog . to transactionLogTime -> t) -> dateTimeCell t
          , sortable (Just "status")  (textCell "Status")                $ tCell    (cellMaybe iconBoolCell . transactionInterfaceSuccess)
          , sortable (Just "subtype") (i18nCell MsgInterfaceSubtype)     $ tCell    (              textCell . transactionInterfaceSubtype)
          , sortable (Just "info")    (i18nCell MsgSystemMessageContent) $ tCellErr (              textCell . transactionInterfaceInfo)
          ]
        dbtSorting = mconcat
          [ singletonMap "time"     $ SortColumn (E.^. TransactionLogTime)
          , singletonMap "status"   $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-success")
          , singletonMap "subtype"  $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-subtype")
          , singletonMap "info"     $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-info"   )
          ]
        dbtFilter   = mempty
        dbtFilterUI = mempty

        dbtStyle  = def
        dbtParams = def
        dbtCsvEncode = noCsvEncode
        dbtCsvDecode = Nothing
        dbtExtraReps = []
    validator = def & defaultSorting [ SortDescBy "time" ]
  tbl <- runDB $ dbTableDB' validator logDBTable
  siteLayoutMsg MsgMenuPrintLog $ do
    setTitleI MsgMenuPrintLog
    [whamlet|^{tbl}|]
