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.Trans.Writer (WriterT, execWriterT)
import Control.Monad.Error.Class (MonadError(..))

import Jobs.Queue
  
import Generics.Deriving.Monoid


data AddRecipientsResult = AddRecipientsResult
  { aurAlreadyRegistered
  , aurNoUniquePrimaryField
  , 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 MsgExamOccurrence) Nothing
      users <- wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing)
        (fslI MsgExamRegistrationInviteField & 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 aurNoUniquePrimaryField) $ do
        let modalTrigger = [whamlet|_{MsgExamRegistrationRegisteredWithoutField (length aurNoUniquePrimaryField)}|]
            modalContent = $(widgetFile "messages/examRegistrationInvitationRegisteredWithoutField")
        tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent)

      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 . existsBy $ UniqueParticipant uid cid) $ do
        lift $ lift examRegister
        throwError $ mempty { aurSuccess = pure userEmail }

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

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

      features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] []

      let courseParticipantField
            | [f] <- features = Just f
            | otherwise       = Nothing

      lift . lift . insert_ $ CourseParticipant
        { courseParticipantCourse = cid
        , courseParticipantUser = uid
        , courseParticipantRegistration = now
        , courseParticipantAllocated = Nothing
        , ..
        }
      lift . lift . audit $ TransactionCourseParticipantEdit cid uid
      lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid
      lift $ lift examRegister

      return $ case courseParticipantField of
        Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail }
        Just _  -> mempty { aurSuccessCourse        = pure userEmail }