fradrive/src/Handler/Admin/Crontab.hs

-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

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

module Handler.Admin.Crontab
  ( getAdminCrontabR
  , getAdminJobsR
  , postAdminJobsR
  ) where

import Import
import Jobs
import Handler.Utils

-- import Data.Aeson (fromJSON)
-- import qualified Data.Aeson as Aeson
-- import qualified Data.Aeson.Types as Aeson
import qualified Data.Aeson.Encode.Pretty as Pretty          

-- import qualified Data.CaseInsensitive as CI
import qualified Data.Text as Text
import qualified Data.Text.Lazy.Builder as Text.Builder

import qualified Data.Map as Map
import qualified Data.HashSet as HashSet
import qualified Data.HashMap.Strict as HashMap

import qualified Data.UUID as UUID

import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E
-- import Database.Esqueleto.Utils.TH


deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 1
  } ''CronNextMatch

  
getAdminCrontabR :: Handler TypedContent
getAdminCrontabR = do
  jState <- getsYesod appJobState
  mCrontab' <- atomically . runMaybeT $ do
    JobState{jobCurrentCrontab} <- MaybeT $ tryReadTMVar jState
    MaybeT $ readTVar jobCurrentCrontab

  let mCrontab = mCrontab' <&> _2 %~ filter (hasn't $ _3 . _MatchNone)

  instanceId <- getsYesod appInstanceID

  selectRep $ do
    provideRep $ do
      crontabBearer <- runMaybeT . hoist runDB $ do
        guardM $ hasGlobalGetParam GetGenerateToken
        uid <- MaybeT maybeAuthId
        guardM . lift . existsBy $ UniqueUserGroupMember UserGroupCrontab uid

        encodeBearer =<< bearerToken (HashSet.singleton . Left $ toJSON UserGroupCrontab) Nothing (HashMap.singleton BearerTokenRouteEval $ HashSet.singleton AdminCrontabR) Nothing (Just Nothing) Nothing

      
      siteLayoutMsg MsgHeadingAdminCrontab $ do
        setTitleI MsgHeadingAdminCrontab
        [whamlet|
          $newline never
          $maybe t <- crontabBearer
            <section>
              <pre .token>
                #{toPathPiece t}
          <section>
            <dl .deflist>
              <dt .deflist__dt>_{MsgAdminInstanceId}
              <dd .deflist__dd .uuid>#{UUID.toText instanceId}
          <section>
            $maybe (genTime, crontab) <- mCrontab
              <p>
                ^{formatTimeW SelFormatDateTime genTime}
              <table .table .table--striped .table--hover>
                $forall (job, lExec, match) <- crontab
                  <tr .table__row>
                    <td .table__td>
                      $case match
                        $of MatchAsap
                          _{MsgCronMatchAsap}
                        $of MatchNone
                          _{MsgCronMatchNone}
                        $of MatchAt t
                          ^{formatTimeW SelFormatDateTime t}
                    <td .table__td>
                      $maybe lT <- lExec
                        ^{formatTimeW SelFormatDateTime lT}
                    <td .table__td .json>
                      #{doEnc job}
            $nothing
              <p .explanation>
                _{MsgAdminCrontabNotGenerated}
        |]
    provideJson mCrontab'
    provideRep . return . Text.Builder.toLazyText $ doEnc mCrontab'
  where
    doEnc :: ToJSON a => a -> _
    doEnc = Pretty.encodePrettyToTextBuilder' Pretty.defConfig
      { Pretty.confIndent = Pretty.Spaces 2
      , Pretty.confCompare = comparing $ \t -> ( t `elem` ["instruction", "job", "notification"]
                                               , Text.splitOn "-" t
                                               )
      }


getAdminJobsR, postAdminJobsR :: Handler Html
getAdminJobsR = postAdminJobsR
postAdminJobsR = do
  let
    jobsDBTable = DBTable{..}
      where
        resultJob :: Lens' (DBRow (Entity QueuedJob)) (Entity QueuedJob)
        resultJob = _dbrOutput

        dbtSQLQuery = return
        dbtRowKey = (E.^. QueuedJobId)
        dbtProj = dbtProjId
        dbtColonnade = dbColonnade $ mconcat -- remove call to dbColonnade if table actions are added
          [ sortable (Just "job")           (i18nCell MsgTableJob)          $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> cellMaybe textCell $ getJobName queuedJobContent
          , sortable (Just "creation-time") (i18nCell MsgTableCreationTime) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> dateTimeCell queuedJobCreationTime
          , sortable (Just "content")       (i18nCell MsgTableJobContent)   $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> cell [whamlet|#{doEnc queuedJobContent}|] & addCellClass ("json"::Text)
          ]
        dbtSorting = Map.fromList 
          [ ("creation-time", SortColumnNullsInv (E.^. QueuedJobCreationTime))
          , ("job"          , SortColumn         (\v -> v E.^. QueuedJobContent E.->>. "job"))
          , ("content"      , SortColumn         (E.^. QueuedJobContent))
          ]
        dbtFilter = Map.fromList
          [
            ("job", FilterColumn $ E.mkContainsFilter (\v -> v E.^. QueuedJobContent E.->>. "job"))
          ]
        dbtFilterUI = \mPrev -> mconcat
          [
            prismAForm (singletonFilter "job" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableJob)
          ]
        dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
        dbtParams = def
        dbtIdent :: Text
        dbtIdent = "queued-jobs"
        dbtCsvEncode = noCsvEncode
        dbtCsvDecode = Nothing
        dbtExtraReps = []
    jobsDBTableValidator = def 
      & defaultSorting [SortDescBy "creation-time"]
  ((), jobsTable) <- runDB $ dbTable jobsDBTableValidator jobsDBTable

  siteLayoutMsg MsgMenuAdminJobs $ do
    setTitleI MsgMenuAdminJobs
    [whamlet|
      ^{jobsTable}
    |]
  where
    doEnc :: ToJSON a => a -> _
    doEnc = Pretty.encodePrettyToTextBuilder' Pretty.defConfig
      { Pretty.confIndent = Pretty.Spaces 2
      , Pretty.confCompare = comparing $ \t -> ( t `elem` ["job", "notification"]
                                               , Text.splitOn "-" t
                                               )
      }
  
    getJobName :: Value -> Maybe Text
    getJobName (Object o) 
      | Just (String s) <- HashMap.lookup "job" o = Just s -- $ kebabToCamel s
    getJobName _ = Nothing