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 Utils.Lens
  
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              :: [UserEmail]
  } deriving (Read, Show, Generic, Typeable)

instance Monoid AddRecipientsResult where
  mempty = memptydefault
  mappend = mappenddefault


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 <- liftHandlerT . 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) (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 alreadyRegistered registeredNoField noCourseRegistration registeredOneField <- 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

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

      when (not $ null alreadyRegistered) $
        tell . pure <=< messageI Success . MsgExamRegistrationParticipantsRegistered $ length registeredOneField

      when (not $ null registeredNoField) $ do
        let modalTrigger = [whamlet|_{MsgExamRegistrationRegisteredWithoutField (length registeredNoField)}|]
            modalContent = $(widgetFile "messages/examRegistrationInvitationRegisteredWithoutField")
        tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent)

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

      when (not $ null registeredOneField) $
        tell . pure <=< messageI Success . MsgExamRegistrationAndCourseParticipantsRegistered $ length registeredOneField

    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 (unTermKey tid) (unSchoolKey ssh) csh examn userIdent

      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 }

      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
        , ..
        }
      lift $ lift examRegister

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


