fradrive/src/Handler/Course/User.hs

module Handler.Course.User
  ( getCUserR, postCUserR
  ) where

import Import

import Utils.Form
import Handler.Utils
import Database.Esqueleto.Utils.TH

import Data.Function ((&))

import qualified Database.Esqueleto as E

import Text.Blaze.Html.Renderer.Text (renderHtml)

import Handler.Course.Register

import Jobs.Queue


getCUserR, postCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
getCUserR = postCUserR
postCUserR tid ssh csh uCId = do
  -- Has authorization checks (OR):
  --
  --   - User is current member of course
  --   - User has submitted in course
  --   - User is member of registered group for course
  --   - User is member of a tutorial for course
  --   - User is corrector for course
  --   - User is a tutor for course
  --   - User is a lecturer for course
  let currentRoute = CourseR tid ssh csh (CUserR uCId)
  Entity dozentId (userShowSex -> showSex) <- requireAuth
  uid <- decrypt uCId
  -- DB reads
  (cid, User{..}, mRegistration, thisUniqueNote, noteText, noteEdits, studies) <- runDB $ do
    cid  <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
    -- Abfrage Benutzerdaten
    user <- get404 uid
    registration <- getBy (UniqueParticipant uid cid)
    -- Abfrage Teilnehmernotiz
    let thisUniqueNote = UniqueCourseUserNote uid cid
    mbNoteEnt <- getBy thisUniqueNote
    (noteText,noteEdits) <- case mbNoteEnt of
      Nothing -> return (Nothing,[])
      (Just (Entity noteKey CourseUserNote{courseUserNoteNote})) -> do
        noteEdits <- E.select $ E.from $ \(edit `E.InnerJoin` usr) -> do
          E.on     $ edit E.^. CourseUserNoteEditUser E.==. usr E.^. UserId
          E.where_ $ edit E.^. CourseUserNoteEditNote E.==. E.val noteKey
          E.orderBy [E.desc $ edit E.^. CourseUserNoteEditTime]
          E.limit 1 -- more will be shown, if changed here
          return (edit E.^. CourseUserNoteEditTime, usr E.^. UserEmail, usr E.^. UserDisplayName, usr E.^. UserSurname)
        return (Just courseUserNoteNote, $(unValueN 4) <$> noteEdits)
    -- Abfrage Studiengänge
    studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
      E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
      E.on $ studyfeat E.^. StudyFeaturesField  E.==. studyterms  E.^. StudyTermsId
      E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
      return  (studyfeat, studydegree, studyterms)
    return (cid, user, registration, thisUniqueNote, noteText, noteEdits, studies)
  let editByWgt = [whamlet|
          $newline never
          <ul .list--iconless>
            $forall (etime,_eemail,ename,_esurname) <- noteEdits
              <li>
                _{MsgLastEdit} ^{editedByW SelFormatDateTime etime ename}
        |] -- _{MsgLastEdit} ^{formatTimeW SelFormatDateTime etime} ^{nameWidget ename esurname}

  ((noteRes, noteView), noteEnctype) <- runFormPost . identifyForm FIDcUserNote . renderAForm FormStandard $
      aopt (annotateField editByWgt htmlField) (fslpI MsgCourseUserNote "HTML" & setTooltip MsgCourseUserNoteTooltip) (Just noteText)
  let noteFrag :: Text
      noteFrag = "notes"
      noteWidget = wrapForm noteView FormSettings
        { formMethod = POST
        , formAction = Just . SomeRoute $ currentRoute :#: noteFrag
        , formEncoding = noteEnctype
        , formAttrs = []
        , formSubmit = FormSubmit
        , formAnchor = Just noteFrag
        }
  formResult noteRes $ \mbNote -> do
    now <- liftIO getCurrentTime
    runDB $ case mbNote of
      Nothing -> do
        -- must delete all edits due to foreign key constraints, which does not make sense -> refactor!
        maybeM (return ()) (\nk -> deleteWhere [CourseUserNoteEditNote ==. nk]) (getKeyBy thisUniqueNote)
        deleteBy thisUniqueNote
        addMessageI Info MsgCourseUserNoteDeleted
      _ | (renderHtml <$> mbNote) == (renderHtml <$> noteText) -> return () -- no changes
      (Just note) -> do
        (Entity noteKey _) <- upsertBy thisUniqueNote (CourseUserNote cid uid note) [CourseUserNoteNote =. note]
        void . insert $ CourseUserNoteEdit dozentId now noteKey
        addMessageI Success MsgCourseUserNoteSaved
    redirect $ currentRoute :#: noteFrag -- reload page after post

  ((regFieldRes, regFieldView), regFieldEnctype) <- runFormPost . identifyForm FIDcRegField $ \csrf ->
    let currentField :: Maybe (Maybe StudyFeaturesId)
        currentField = courseParticipantField . entityVal <$> mRegistration
     in over _2 ((toWidget csrf <>) . fvInput) <$> mreq (studyFeaturesFieldFor Nothing True (maybeToList $ join currentField) $ Just uid) ("" & addAutosubmit) currentField

  let registrationFieldFrag :: Text
      registrationFieldFrag = "registration-field"
      regFieldWidget = wrapForm regFieldView FormSettings
        { formMethod = POST
        , formAction = Just . SomeRoute $ currentRoute :#: registrationFieldFrag
        , formEncoding = regFieldEnctype
        , formAttrs = []
        , formSubmit = FormAutoSubmit
        , formAnchor = Just registrationFieldFrag
        }
  for_ mRegistration $ \(Entity pId CourseParticipant{..}) ->
    formResult regFieldRes $ \courseParticipantField' -> do
      runDB $ do
        update pId [ CourseParticipantField =. courseParticipantField' ]
        audit $ TransactionCourseParticipantEdit cid uid
        addMessageI Success MsgCourseStudyFeatureUpdated
      redirect $ currentRoute :#: registrationFieldFrag

  mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
  let regButton
        | is _Just mRegistration = BtnCourseDeregister
        | otherwise = BtnCourseRegister
  ((regButtonRes, regButtonView), regButtonEnctype) <- runFormPost . identifyForm FIDcRegButton $
    if | is _Just $ courseParticipantAllocated . entityVal =<< mRegistration
         -> renderWForm FormStandard $ fmap (regButton, )
              <$  (wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationShouldLogTip)
              <*> optionalActionW (areq (textField & cfStrip & guardField (not . null)) (fslI MsgCourseDeregistrationAllocationReason & setTooltip MsgCourseDeregistrationAllocationReasonTip) Nothing) (fslI MsgCourseDeregistrationAllocationShouldLog) (Just True)
       | otherwise
         -> \csrf -> pure (FormSuccess (regButton, Nothing), toWidget csrf)

  let registrationButtonFrag :: Text
      registrationButtonFrag = "registration-button"
      regButtonWidget = wrapForm' regButton regButtonView FormSettings
        { formMethod = POST
        , formAction = Just . SomeRoute $ currentRoute :#: registrationButtonFrag
        , formEncoding = regButtonEnctype
        , formAttrs = []
        , formSubmit = FormSubmit
        , formAnchor = Just registrationButtonFrag
        }
  formResult regButtonRes $ \case
    _
      | not mayRegister
        -> permissionDenied "User may not be registered"
    (BtnCourseDeregister, mbReason)
      | Just (Entity _pId CourseParticipant{..}) <- mRegistration
        -> do
          runDB $ do
            deregisterParticipant courseParticipantUser courseParticipantCourse

            whenIsJust mbReason $ \reason -> do
              now <- liftIO getCurrentTime
              insert_ $ AllocationDeregister courseParticipantUser (Just cid) now (Just reason)
          addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk
          redirect $ CourseR tid ssh csh CUsersR
      | otherwise
        -> invalidArgs ["User not registered"]
    (BtnCourseRegister, _) -> do
      now <- liftIO getCurrentTime
      let field
            | [(Entity featId _, _, _)] <- filter (\(Entity _ StudyFeatures{..}, _, _) -> studyFeaturesValid) studies
            = Just featId
            | otherwise
            = Nothing
      pId <- runDBJobs $ do
        pId <- insertUnique $ CourseParticipant cid uid now field Nothing
        when (is _Just pId) $ do
          queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid
          audit $ TransactionCourseParticipantEdit cid uid
        return pId
      case pId of
        Just _  -> do
          addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
          redirect currentRoute
        Nothing -> invalidArgs ["User already registered"]
    _other -> error "Invalid @regButton@"

  mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime

  -- generate output
  let headingLong
        | is _Just mRegistration
        , Just sex <- guardOn showSex =<< userSex
        = [whamlet|^{nameWidget userDisplayName userSurname} (_{ShortSex sex}), _{MsgCourseMemberOf} #{csh} #{tid}|]
        | is _Just mRegistration
        = [whamlet|^{nameWidget userDisplayName userSurname}, _{MsgCourseMemberOf} #{csh} #{tid}|]
        | Just sex <- guardOn showSex =<< userSex
        = [whamlet|^{nameWidget userDisplayName userSurname} (_{ShortSex sex}), _{MsgCourseAssociatedWith} #{csh} #{tid}|]
        | otherwise
        = [whamlet|^{nameWidget userDisplayName userSurname}, _{MsgCourseAssociatedWith} #{csh} #{tid}|]
      headingShort = prependCourseTitle tid ssh csh $ SomeMessage userDisplayName
  siteLayout headingLong $ do
    setTitleI headingShort
    $(widgetFile "course-user")