fradrive/src/Handler/Course/ParticipantInvite.hs

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

module Handler.Course.ParticipantInvite
  ( getCAddUserR, postCAddUserR
  , AddParticipantsResult(..)
  , addParticipantsResultMessages
  , registerUsers, registerUser
  ) where

import Import

import Handler.Utils
import Handler.Utils.Course
import Handler.Utils.Avs

import Jobs.Queue

--import Data.Aeson hiding (Result(..))
--import qualified Data.CaseInsensitive as CI
--import qualified Data.HashSet as HashSet
import Data.List (genericLength)
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Time.Zones as TZ
import qualified Data.Set as Set

import Control.Monad.Except (MonadError(..))
import Generics.Deriving.Monoid (memptydefault, mappenddefault)


data AddParticipantsResult = AddParticipantsResult
  { aurAlreadyRegistered
  , aurAlreadyTutorialMember
  , aurRegisterSuccess
  , aurTutorialSuccess       :: Set UserId
  } deriving (Read, Show, Generic, Typeable)

instance Semigroup AddParticipantsResult where
  (<>) = mappenddefault

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


getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCAddUserR = postCAddUserR
postCAddUserR tid ssh csh = do
  cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
  -- mr <- getMessageRender
  today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime

  let
    cfCommaSeparatedSet :: forall m. Functor m => Field m Text -> Field m (Set Text)
    cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.splitOn ",") (Text.intercalate ", " . Set.toList)

  ((usersToRegister, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do
    users <- wreq (textField & cfCommaSeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty
    mTutorial <- optionalActionW
      ( areq textField (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just $ tshow today) ) -- TODO: use user date display setting
      ( fslI MsgCourseParticipantsRegisterTutorialOption )
      ( Just True )
    return $ Map.fromSet . const <$> mTutorial <*> users

  formResultModal usersToRegister (CourseR tid ssh csh CUsersR) $
    registerUsers cid -- TODO: register for tutorial, if specified

  let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading

  siteLayoutMsg heading $ do
    setTitleI heading
    wrapForm formWgt def
      { formEncoding
      , formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR
      }


registerUsers :: CourseId -> Map Text (Maybe Text) -> WriterT [Message] Handler ()
registerUsers cid usersToRegister = do
  avsUsers :: Map Text (Maybe UserId) <- fmap Map.fromList . forM (Map.keys usersToRegister) $ \userIdent -> do
    mUser <- liftHandler $ upsertAvsUser userIdent -- TODO: upsertAvsUser should return whole Entity
    return (userIdent, mUser)

  when (null avsUsers) $
    tell . pure =<< messageI Error MsgCourseParticipantsRegisterNoneGiven

  -- register known users
  -- tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT $ imapM_ (registerUser cid) uids

  -- unless (null avsUsers) $
  --   tell . pure <=< messageI Success . MsgCourseParticipantsAddedByAvs $ length avsUsers


addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX)
                              => AddParticipantsResult
                              -> ReaderT (YesodPersistBackend UniWorX) m [Message]
addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do
  aurAlreadyRegistered' <-
    fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurAlreadyRegistered)

  unless (null aurAlreadyRegistered) $ do
    let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|]
        modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered")
    tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
  -- TODO: aurAlreadyTutorialMember

  unless (null aurRegisterSuccess) $
    tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurRegisterSuccess
  unless (null aurTutorialSuccess) $
    tell . pure <=< messageI Success . MsgCourseUsersTutorialRegistered . genericLength $ Set.toList aurTutorialSuccess


registerUser :: CourseId
             -> UserId
             -> WriterT AddParticipantsResult (YesodJobDB UniWorX) ()
registerUser cid uid = exceptT tell tell $ do
  whenM (lift . lift $ exists [CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive]) $
    throwError $ mempty { aurAlreadyRegistered = Set.singleton uid }

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

  return $ mempty { aurRegisterSuccess = Set.singleton uid }