fradrive/src/Handler/Course/Register.hs

-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

module Handler.Course.Register
  ( ButtonCourseRegister(..)
  , CourseRegisterForm(..)
  , courseRegisterForm, courseMayReRegister
  , getCRegisterR, postCRegisterR
  , deregisterParticipant
  ) where

import Import

import Handler.Utils
import Handler.Utils.Exam

import Utils.Course

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


-- Dedicated CourseRegistrationButton
data ButtonCourseRegister = BtnCourseRegister | BtnCourseDeregister
  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic)
instance Universe ButtonCourseRegister
instance Finite ButtonCourseRegister
nullaryPathPiece ''ButtonCourseRegister $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''ButtonCourseRegister id
instance Button UniWorX ButtonCourseRegister where
  btnClasses BtnCourseRegister           = [BCIsButton, BCPrimary]
  btnClasses BtnCourseDeregister         = [BCIsButton, BCDanger]

  btnLabel   BtnCourseRegister           = [whamlet|#{iconEnrol True}  _{MsgBtnCourseRegister}|]
  btnLabel   BtnCourseDeregister         = [whamlet|#{iconEnrol False} _{MsgBtnCourseDeregister}|]


data CourseRegisterForm = CourseRegisterForm
  {}

courseRegisterForm :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Course -> m (AForm Handler CourseRegisterForm, ButtonCourseRegister)
-- ^ `CourseRegisterForm` for current user
courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
  muid <- maybeAuthId
  ata <- getSessionActiveAuthTags
  now <- liftIO getCurrentTime

  registration <- runDB .
    fmap join . for muid $ fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy . flip UniqueParticipant cid
  let btn | is _Just registration
          = BtnCourseDeregister
          | otherwise
          = BtnCourseRegister
      isRegistered = btn == BtnCourseDeregister
  return . (, btn) . wFormToAForm $ do
    MsgRenderer mr <- getMsgRenderer

    secretRes <- if
      | Just secret <- courseRegisterSecret
      , not isRegistered
        -> let guardSecret (FormSuccess secret')
                 | secret == secret' = return $ FormSuccess ()
                 | otherwise         = formFailure [MsgCourseSecretWrong]
               guardSecret  FormMissing       = return   FormMissing
               guardSecret (FormFailure errs) = return $ FormFailure errs
            in guardSecret =<< wreq textField (fslpI MsgCourseSecret $ mr MsgCourseSecret) Nothing
      | otherwise
        -> return $ FormSuccess ()

    mayViewCourseAfterDeregistration <- liftHandler . runDBRead $ E.selectExists . E.from $ \course -> do
      E.where_ $  course E.^. CourseId E.==. E.val cid
           E.&&. (       isSchoolAdminLike muid ata (course E.^. CourseSchool)
                   E.||. mayEditCourse muid ata course
                   E.||. courseIsVisible now course
                   E.||. isCourseLecturer muid ata (course E.^. CourseId)
                   E.||. isCourseTutor muid ata (course E.^. CourseId)
                   E.||. isCourseSheetCorrector muid ata (course E.^. CourseId)
                   E.||. isCourseExamCorrector muid ata (course E.^. CourseId)
                 )

    mayReRegister <- liftHandler . runDB . courseMayReRegister $ Entity cid Course{..}

    when (isRegistered && not mayViewCourseAfterDeregistration) $
      wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationFromInvisibleCourse
    unless mayReRegister $
      wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationNoReRegistration

    return $ CourseRegisterForm <$ secretRes

courseMayReRegister :: Entity Course -> DB Bool
courseMayReRegister (Entity cid Course{..}) = do
  registrations <- count [ CourseParticipantState ==. CourseParticipantActive, CourseParticipantCourse ==. cid ]
  let capacity = maybe True (>= registrations) courseCapacity

  wouldHaveWriteAccessTo [(AuthCapacity, capacity), (AuthCourseRegistered, False)] $ CourseR courseTerm courseSchool courseShorthand CRegisterR


-- | Workaround for klicking register button without being logged in.
-- After log in, the user sees a "get request not supported" error.
getCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCRegisterR tid ssh csh = do
  muid <- maybeAuthId
  case muid of
    Nothing -> addMessageI Info MsgLoginNecessary
    (Just uid) -> runDB $ do
      cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
      registration <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
      when (isNothing registration) $ addMessageI Warning MsgRegisterRetry
  redirect $ CourseR tid ssh csh CShowR

postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
postCRegisterR tid ssh csh = do
  uid <- requireAuthId
  course@(Entity cid Course{..}) <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
  (courseRegisterForm', courseRegisterButton) <- courseRegisterForm course
  ((regResult,_), _) <- runFormPost $ renderAForm FormStandard courseRegisterForm'
  formResult regResult $ \CourseRegisterForm{} -> do
    cTime <- liftIO getCurrentTime
    let
      mkRegistration = do
        audit $ TransactionCourseParticipantEdit cid uid
        memcachedByInvalidate (AuthCacheCourseRegisteredList courseTerm courseSchool courseShorthand) (Proxy @(Set UserId))
        entityKey <$> upsert
          (CourseParticipant cid uid cTime CourseParticipantActive)
          [ CourseParticipantRegistration =. cTime
          , CourseParticipantState =. CourseParticipantActive
          ]

    case courseRegisterButton of
      BtnCourseRegister -> runDB $ do
        void mkRegistration
        addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
      BtnCourseDeregister -> runDB . setSerializable $ do
        part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
        forM_ part . const $ do
          deregisterParticipant uid course

        addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk
  muid <- maybeAuthId
  ata <- getSessionActiveAuthTags
  now <- liftIO getCurrentTime
  courseVisible <- runDB . E.selectExists . E.from $ \course' -> do
    E.where_ $ course' E.^. CourseId E.==. E.val cid
         E.&&. mayViewCourse muid ata now course'
  redirect $ bool NewsR (CourseR tid ssh csh CShowR) courseVisible


deregisterParticipant :: UserId -> Entity Course -> DB ()
deregisterParticipant uid (Entity cid Course{..}) = do
  part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
  forM_ part $ \(Entity partId CourseParticipant{}) -> do
    update partId [CourseParticipantState =. CourseParticipantInactive False]
    audit $ TransactionCourseParticipantDeleted cid uid
    memcachedByInvalidate (AuthCacheCourseRegisteredList courseTerm courseSchool courseShorthand) (Proxy @(Set UserId))

  examRegistrations <- E.select . E.from $ \(examRegistration `E.InnerJoin` exam) -> do
    E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
    E.where_ $ exam E.^. ExamCourse E.==. E.val cid
         E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid
    return examRegistration
  forM_ examRegistrations $ \(Entity _ ExamRegistration{..}) -> do
    deregisterExamUsers examRegistrationExam $ pure examRegistrationUser

  E.delete . E.from $ \tutorialParticipant -> do
    let tutorialCourse = E.subSelectForeign tutorialParticipant TutorialParticipantTutorial (E.^. TutorialCourse)

    E.where_ $ tutorialCourse E.==. E.val cid
         E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid