fradrive/src/Handler/Exam/AddUser.hs

module Handler.Exam.AddUser
  ( getEAddUserR, postEAddUserR
  ) where

import Import hiding (Option(..))
import Handler.Exam.RegistrationInvite

import Handler.Utils
import Handler.Utils.Exam
import Handler.Utils.Invitations

import qualified Data.Set as Set

import Data.Semigroup (Option(..))

import Control.Monad.Error.Class (MonadError(..))

import Jobs.Queue

import Generics.Deriving.Monoid


data AddRecipientsResult = AddRecipientsResult
  { aurAlreadyRegistered
  , aurNoCourseRegistration
  , aurSuccess
  , aurSuccessCourse        :: [UserEmail]
  } deriving (Read, Show, Generic, Typeable)

instance Semigroup AddRecipientsResult where
  (<>) = mappenddefault

instance Monoid AddRecipientsResult where
  mempty = memptydefault
  mappend = (<>)


getEAddUserR, postEAddUserR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getEAddUserR = postEAddUserR
postEAddUserR tid ssh csh examn = do
    eEnt@(Entity eid Exam{..}) <- runDB $ fetchExam tid ssh csh examn
    ((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do
      now <- liftIO getCurrentTime
      occurrences <- liftHandler . runDB $ selectList [ExamOccurrenceExam ==. eid] []

      let
        localNow = utcToLocalTime now
        tomorrowEndOfDay = case localTimeToUTC (LocalTime (addDays 2 $ localDay localNow) midnight) of
          LTUUnique utc' _ -> utc'
          _other           -> UTCTime (addDays 2 $ utctDay now) 0
        earliestDate = getOption . fmap getMin $ mconcat
          [ Option $ Min <$> examStart
          , foldMap (Option . Just . Min . examOccurrenceStart . entityVal) occurrences
          ]
        modifiedEarliestDate = earliestDate <&> \earliestDate'@(utcToLocalTime -> localEarliestDate')
          -> case localTimeToUTC (LocalTime (addDays (-1) $ localDay localEarliestDate') midnight) of
               LTUUnique utc' _ -> utc'
               _other           -> UTCTime (addDays (-1) $ utctDay earliestDate') 0
        defDeadline
          | Just registerTo <- examRegisterTo
          , registerTo > now
          = registerTo
          | Just earliestDate' <- modifiedEarliestDate
          = max tomorrowEndOfDay earliestDate'
          | otherwise
          = tomorrowEndOfDay

      deadline <- wreq utcTimeField (fslI MsgExamRegistrationInviteDeadline) (Just defDeadline)
      enlist <- wpopt checkBoxField (fslI MsgExamRegistrationEnlistDirectly & setTooltip MsgExamRegistrationEnlistDirectlyTip) (Just False)
      registerCourse <- wpopt checkBoxField (fslI MsgExamRegistrationRegisterCourse & setTooltip MsgExamRegistrationRegisterCourseTip) (Just False)
      occurrence <- wopt (examOccurrenceField eid) (fslI MsgTableExamOccurrence) Nothing
      mr <- getMessageRender
      users <- wreq (multiUserInvitationField . maybe MUIAlwaysInvite (const $ MUILookupAnyUser Nothing) $ formResultToMaybe enlist)
        (fslpI MsgExamRegistrationInviteField (mr MsgLdapIdentificationOrEmail) & setTooltip MsgMultiEmailFieldTip) Nothing
      return $ (,,,) <$> deadline <*> registerCourse <*> occurrence <*> users

    formResultModal usersToEnlist (CExamR tid ssh csh examn EUsersR) $ processUsers eEnt

    let heading = prependCourseTitle tid ssh csh MsgExamParticipantsRegisterHeading

    siteLayoutMsg heading $ do
      setTitleI heading
      wrapForm formWgt def
        { formEncoding
        , formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAddUserR
        }
  where
    processUsers :: Entity Exam -> (UTCTime, Bool, Maybe ExamOccurrenceId, Set (Either UserEmail UserId)) -> WriterT [Message] Handler ()
    processUsers (Entity eid Exam{..}) (deadline, registerCourse, occId, users) = do
      let (emails,uids) = partitionEithers $ Set.toList users
      AddRecipientsResult{..} <- lift . runDBJobs $ do
        -- send Invitation eMails to unkown users
        sinkInvitationsF examRegistrationInvitationConfig [(mail,eid,(InvDBDataExamRegistration occId deadline registerCourse, InvTokenDataExamRegistration)) | mail <- emails]
        -- register known users
        execWriterT $ mapM (registerUser examCourse eid registerCourse occId) uids

      unless (null emails) $
        tell . pure <=< messageI Success . MsgExamParticipantsInvited $ length emails

      unless (null aurSuccess) $
        tell . pure <=< messageI Success . MsgExamRegistrationParticipantsRegistered $ length aurSuccess

      unless (null aurNoCourseRegistration) $ do
        let modalTrigger = [whamlet|_{MsgExamRegistrationNotRegisteredWithoutCourse (length aurNoCourseRegistration)}|]
            modalContent = $(widgetFile "messages/examRegistrationInvitationNotRegisteredWithoutCourse")
        tell . pure <=< messageWidget Error $ msgModal modalTrigger (Right modalContent)

      unless (null aurSuccessCourse) $
        tell . pure <=< messageI Success . MsgExamRegistrationAndCourseParticipantsRegistered $ length aurSuccessCourse

    registerUser :: CourseId -> ExamId -> Bool -> Maybe ExamOccurrenceId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) ()
    registerUser cid eid registerCourse occId uid = exceptT tell tell $ do
      User{..} <- lift . lift $ getJust uid
      now <- liftIO getCurrentTime

      let
        examRegister :: YesodJobDB UniWorX ()
        examRegister = do
          insert_ $ ExamRegistration eid uid occId now
          audit $ TransactionExamRegister eid uid

      whenM (lift . lift . existsBy $ UniqueExamRegistration eid uid) $
        throwError $ mempty { aurAlreadyRegistered = pure userEmail }

      whenM (lift . lift $ exists [ CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive ]) $ do
        lift $ lift examRegister
        throwError $ mempty { aurSuccess = pure userEmail }

      unless registerCourse $
        throwError $ mempty { aurNoCourseRegistration = pure userEmail }

      lift . lift . hoist lift $ guardAuthResult =<< evalAccessDB (CourseR tid ssh csh CAddUserR) True


      lift . lift . void $ upsert
        CourseParticipant
          { courseParticipantCourse = cid
          , courseParticipantUser = uid
          , courseParticipantRegistration = now
          , courseParticipantAllocated = Nothing
          , courseParticipantState = CourseParticipantActive
          , ..
          }
        [ CourseParticipantRegistration =. now
        , CourseParticipantAllocated =. Nothing
        , CourseParticipantState =. CourseParticipantActive
        ]
      lift . lift . audit $ TransactionCourseParticipantEdit cid uid
      lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid
      lift $ lift examRegister

      return $ mempty { aurSuccessCourse = pure userEmail }