-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

module Handler.Course.List
  ( makeCourseTable
  , getCourseListR
  , getTermCurrentR
  , getTermSchoolCourseListR
  , getTermCourseListR
  ) where

import Import

import Data.Maybe (fromJust)

import Utils.Course
import Utils.Form
import Handler.Utils hiding (colSchoolShort)

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


type CourseTableData = DBRow
  ( Entity Course
  , Bool -- isRegistered
  , Entity School
  , [Entity User]
  , Bool -- mayEditCourse
  )

resultCourse :: Lens' CourseTableData (Entity Course)
resultCourse = _dbrOutput . _1

resultSchool :: Lens' CourseTableData (Entity School)
resultSchool = _dbrOutput . _3
  
resultIsRegistered :: Lens' CourseTableData Bool
resultIsRegistered = _dbrOutput . _2

resultLecturers :: Traversal' CourseTableData (Entity User)
resultLecturers = _dbrOutput . _4 . traverse

resultMayEditCourse :: Lens' CourseTableData Bool
resultMayEditCourse = _dbrOutput . _5


type CourseTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School))

queryCourse :: IndexPreservingGetter CourseTableExpr (E.SqlExpr (Entity Course))
queryCourse = to $(E.sqlIJproj 2 1)

querySchool :: IndexPreservingGetter CourseTableExpr (E.SqlExpr (Entity School))
querySchool = to $(E.sqlIJproj 2 2)

queryParticipants :: IndexPreservingGetter CourseTableExpr (E.SqlExpr (E.Value Int))
queryParticipants = queryCourse . to (E.^. CourseId) . to numCourseParticipants

queryIsRegistered :: Maybe UserId
                  -> AuthTagActive
                  -> IndexPreservingGetter CourseTableExpr (E.SqlExpr (E.Value Bool))
queryIsRegistered muid ata = queryCourse . to (E.^. CourseId) . to (isCourseParticipant muid ata)

queryMayViewCourse :: Maybe UserId
                   -> AuthTagActive
                   -> UTCTime -- ^ @now@
                   -> IndexPreservingGetter CourseTableExpr (E.SqlExpr (E.Value Bool))
queryMayViewCourse muid ata now = to . runReader $ do
  course <- view queryCourse
  return $ mayViewCourse muid ata now course

queryIsEditor :: Maybe UserId
              -> AuthTagActive
              -> IndexPreservingGetter CourseTableExpr (E.SqlExpr (E.Value Bool))
queryIsEditor muid ata = queryCourse . to (mayEditCourse muid ata)


colCourse :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colCourse = sortable (Just "course") (i18nCell MsgFilterCourse)
          $ \(view resultCourse -> Entity _ Course{..}) ->
            anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
              [whamlet|_{courseName}|]

colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colDescription = sortable Nothing mempty
          $ \(view resultCourse -> Entity _ Course{..}) -> maybeCell courseDescription modalCell

colCShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colCShort = sortable (Just "cshort") (i18nCell MsgFilterCourseShort)
          $ \(view resultCourse -> Entity _ Course{..}) ->
            anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|_{courseShorthand}|]

colTerm :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colTerm = sortable (Just "term") (i18nCell MsgFilterTerm)
          $ \(view resultCourse -> Entity _ Course{..}) ->
            anchorCell (TermCourseListR courseTerm) [whamlet|#{courseTerm}|]

colSchoolShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgFilterCourseSchoolShort) $ \res
  -> let Entity _ Course{..} = res ^. resultCourse
         Entity _ School{..} = res ^. resultSchool
      in anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolShorthand}|]

colRegistered :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colRegistered = sortable (Just "registered") (i18nCell MsgFilterRegistered) $ views resultIsRegistered ((spacerCell <>) . tickmarkCell)


makeCourseTable :: (ToSortable h, Functor h)
                => Colonnade h CourseTableData (DBCell Handler ()) -> PSValidator Handler () -> DB Widget
makeCourseTable colChoices psValidator' = do
  let psValidator = psValidator'
        & forceFilter "may-read" (Any True)

  muid <- lift maybeAuthId
  now <- liftIO getCurrentTime
  ata <- getSessionActiveAuthTags

  let dbtSQLQuery :: CourseTableExpr -> E.SqlQuery _
      dbtSQLQuery = runReaderT $ do
        course <- view queryCourse
        school <- view querySchool

        lift . E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId

        registered <- view $ queryIsRegistered muid ata
        isEditor <- view $ queryIsEditor muid ata

        return (course, registered, school, isEditor)
      lecturerQuery cid (user `E.InnerJoin` lecturer) = do
        E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
        E.where_ $ cid E.==. lecturer E.^. LecturerCourse
             E.&&. lecturer E.^. LecturerType E.==. E.val CourseLecturer
        return user
      isCourseAdminQuery cid (user `E.InnerJoin` lecturer) = do
        E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
        E.where_ $ cid E.==. lecturer E.^. LecturerCourse
        return user
      dbtProj :: _ CourseTableData
      dbtProj = dbtProjSimple $ \(course, E.Value registered, school, E.Value isEditor) -> do
        lecturerList <- E.select $ E.from $ lecturerQuery $ E.val $ entityKey course
        return (course, registered, school, lecturerList, isEditor)
  
  dbTableWidget' psValidator DBTable
    { dbtSQLQuery
    , dbtRowKey = views queryCourse (E.^. CourseId)
    , dbtColonnade = colChoices
    , dbtProj
    , dbtSorting = mconcat
      [ singletonMap "course"         . SortColumn $ views queryCourse (E.^. CourseName)
      , singletonMap "cshort"         . SortColumn $ views queryCourse (E.^. CourseShorthand)
      , singletonMap "term"           . SortColumn $ views queryCourse (E.^. CourseTerm)
      , singletonMap "school"         . SortColumn $ views querySchool (E.^. SchoolName)
      , singletonMap "schoolshort"    . SortColumn $ views querySchool (E.^. SchoolShorthand)
      , singletonMap "register-from"  . SortColumn $ views queryCourse (E.^. CourseRegisterFrom)
      , singletonMap "register-to"    . SortColumn $ views queryCourse (E.^. CourseRegisterTo)
      , singletonMap "members"        . SortColumn $ view queryParticipants
      , singletonMap "registered"     . SortColumn . view $ queryIsRegistered muid ata
      ]
    , dbtFilter = mconcat
      [ singletonMap "may-read" . FilterColumn $ \t (Any b) -> views (queryMayViewCourse muid ata now) (E.==. E.val b) t
      , singletonMap "course" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseName)
      , singletonMap "cshort" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseShorthand)
      , singletonMap "term" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseTerm)
      , singletonMap "school" . FilterColumn . E.mkExactFilter $ views querySchool (E.^. SchoolName)
      , singletonMap "schoolshort" . FilterColumn . E.mkExactFilter $ views querySchool (E.^. SchoolShorthand)
      , singletonMap "lecturer" . FilterColumn . E.mkExistsFilter $ \t (c :: Text) -> E.from $ \t' -> do
          user <- isCourseAdminQuery (view queryCourse t E.^. CourseId) t'
          E.where_ $ user E.^. UserDisplayName `E.hasInfix` E.val c
      , singletonMap "openregistration" . FilterColumn . E.mkExactFilterLast . runReader $ do
          course <- view queryCourse

          let regTo   = course E.^. CourseRegisterTo
              regFrom = course E.^. CourseRegisterFrom
              courseOpen = E.maybe E.false (\f -> f E.<=. E.val now) regFrom
                     E.&&. E.maybe E.true  (\t -> E.val now E.<=. t) regTo

          return courseOpen
      , singletonMap "registered" . FilterColumn . E.mkExactFilterLast . view $ queryIsRegistered muid ata
      , singletonMap "search" . FilterColumn $ \(view queryCourse -> course) criterion -> case getLast (criterion :: Last Text) of
          Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
          Just needle -> (E.castString (course E.^. CourseName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
                   E.||. (E.castString (course E.^. CourseShorthand) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
                   E.||. (E.maybe (E.val mempty) (E.castString . esqueletoMarkupOutput) (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
      , singletonMap "search-shorthand" . FilterColumn $ \(view queryCourse -> course) criterion -> case getLast (criterion :: Last Text) of
          Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
          Just needle -> E.castString (course E.^. CourseShorthand) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)
      , singletonMap "search-title" . FilterColumn $ \(view queryCourse -> course) criterion -> case getLast (criterion :: Last Text) of
          Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
          Just needle -> E.castString (course E.^. CourseName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)
      ]
    , dbtFilterUI = \mPrev -> mconcat $ catMaybes
      [ pure $ prismAForm (singletonFilter "term" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift termField) (fslI MsgTableTerm)
      , pure $ prismAForm (singletonFilter "schoolshort" . maybePrism (_PathPiece . from _SchoolId)) mPrev $ aopt (hoistField lift schoolField) (fslI MsgTableCourseSchool)
      , pure $ prismAForm (singletonFilter "lecturer") mPrev $ aopt textField (fslI MsgCourseLecturer)
      , pure $ prismAForm (singletonFilter "search") mPrev $ aopt textField (fslI MsgFilterCourseSearch)
      , pure $ prismAForm (singletonFilter "search-shorthand") mPrev $ aopt textField (fslI MsgFilterCourseSearchShorthand)
      , pure $ prismAForm (singletonFilter "search-title") mPrev $ aopt textField (fslI MsgFilterCourseSearchTitle)
      , pure $ prismAForm (singletonFilter "openregistration" . maybePrism _PathPiece) mPrev $ fmap (\x -> if isJust x && not (fromJust x) then Nothing else x) . aopt checkBoxField (fslI MsgFilterCourseRegisterOpen)
      , guardOn (is _Just muid)
             $ prismAForm (singletonFilter "registered" . maybePrism _PathPiece) mPrev (aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterCourseRegistered))
      ]
    , dbtStyle = def
      { dbsFilterLayout = defaultDBSFilterLayout
      , dbsTemplate = DBSTCourse resultCourse resultLecturers resultIsRegistered resultSchool resultMayEditCourse
      }
    , dbtParams = def
    , dbtIdent = "courses" :: Text
    , dbtCsvEncode = noCsvEncode
    , dbtCsvDecode = Nothing
    , dbtExtraReps = []
    }

getCourseListR :: Handler Html
getCourseListR = do
  muid <- maybeAuthId
  let colonnade = widgetColonnade $ mconcat
        [ colCourse -- colCourseDescr
        , colDescription
        , colSchoolShort
        , colTerm
        , colCShort
        , maybe mempty (const colRegistered) muid
        ]
      validator = def
        & defaultSorting [SortDescBy "term",SortAscBy "course"]
  now <- liftIO getCurrentTime
  coursesTable <- runDB $ do
    activeTs <- selectList [TermActiveFrom <=. now
                , FilterOr [TermActiveTo >. Just now, TermActiveTo ==. Nothing]
                , FilterOr [TermActiveFor ==. muid, TermActiveFor ==. Nothing]   -- TermActiveFor <-. [Nothing, muid] did not work as intended
                ] [Desc TermActiveTerm]
    let addTermFilter = if null activeTs 
          then id
          else defaultFilter $ singletonMap "term" [toPathPiece termActiveTerm | Entity _ TermActive{termActiveTerm} <- activeTs]
    makeCourseTable colonnade (validator & addTermFilter)
  defaultLayout $ do
    setTitleI MsgCourseListTitle
    $(widgetFile "courses")

getTermCurrentR :: Handler Html
getTermCurrentR = maybeT notFound $ do
  currentTerm <- MaybeT $ runDB getCurrentTerm
  redirect (CourseListR, [("courses-term", toPathPiece currentTerm)])

getTermSchoolCourseListR :: TermId -> SchoolId -> Handler Html
getTermSchoolCourseListR tid ssh = redirect (CourseListR, [("courses-term", toPathPiece tid), ("courses-schoolshort", toPathPiece ssh)])

getTermCourseListR :: TermId -> Handler Html
getTermCourseListR tid = redirect (CourseListR, [("courses-term", toPathPiece tid)])
