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
  ) where

import Import

import Handler.Utils
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 AddUsers = AddUsers
  { auUsers    :: Set Text
  , auTutorial :: Maybe (CI Text)
  } deriving (Eq, Ord, Read, Show, Generic, Typeable)


data AddParticipantsResult = AddParticipantsResult
  { aurNotFound              :: Set Text
  , 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
    auUsers <- wreq (textField & cfCommaSeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty
    auTutorial <- optionalActionW
      ( areq (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just . CI.mk $ tshow today) ) -- TODO: use user date display setting
      ( fslI MsgCourseParticipantsRegisterTutorialOption )
      ( Just True )
    return $ AddUsers <$> auUsers <*> auTutorial

  -- let dest = CourseR tid ssh csh . maybe CUsersR (flip TutorialR TUsersR . CI.mk) . join . fmap auTutorial $ formResult' usersToRegister
  let dest | Just AddUsers{auTutorial=Just tutn} <- formResult' usersToRegister
             = CTutorialR tid ssh csh tutn TUsersR
           | otherwise
             = CourseR tid ssh csh CUsersR
  formResultModal usersToRegister dest $ \AddUsers{..} -> hoist runDBJobs $ do
    uids <- registerUsers cid auUsers
    for_ auTutorial $ \tutorialName -> lift $ do
      -- TODO: move somewhere else
      now <- liftIO getCurrentTime
      Entity tutId _ <- upsert
        Tutorial
          { tutorialCourse = cid
          , tutorialType = CI.mk mempty -- TODO: remove type? unneeded?
          , tutorialCapacity = Nothing
          , tutorialRoom = Nothing
          , tutorialRoomHidden = False
          , tutorialTime = Occurrences mempty mempty
          , tutorialRegGroup = Nothing -- TODO: remove
          , tutorialRegisterFrom = Nothing
          , tutorialRegisterTo = Nothing
          , tutorialDeregisterUntil = Nothing
          , tutorialLastChanged = now
          , tutorialTutorControlled = False
          , ..
          }
        [ TutorialName        =. tutorialName
        , TutorialLastChanged =. now
        ]
      for_ uids $ \tutorialParticipantUser -> upsert
        TutorialParticipant
          { tutorialParticipantTutorial = tutId
          , ..
          }
        []
      -- tell . pure <=< messageI Success . MsgCourseParticipantsRegisteredTutorial $ length uids

  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 -> Set Text -> WriterT [Message] (YesodJobDB UniWorX) [UserId]
registerUsers cid auUsers = do
  avsUsers :: Map Text (Maybe UserId) <- sequenceA . flip Map.fromSet auUsers $
    liftHandler . upsertAvsUser -- TODO: upsertAvsUser should return whole Entity

  if
    | null avsUsers
      -> tell . pure =<< messageI Error MsgCourseParticipantsRegisterNoneGiven
    | otherwise
      -- register retrieved users
      -> tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT . mapM_ (registerUser cid) $ Map.toList avsUsers

  return . catMaybes $ Map.elems avsUsers


addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX)
                              => AddParticipantsResult
                              -> ReaderT (YesodPersistBackend UniWorX) m [Message]
addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do
  unless (null aurNotFound) $ do
    let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisterNotFoundInAvs (length aurNotFound)}|]
        modalContent = $(widgetFile "messages/courseInvitationNotFoundInAvs")
    tell . pure <=< messageWidget Error $ msgModal modalTrigger (Right modalContent)

  aurAlreadyRegistered'     <- fmap sort (lift . mapM getJust $ Set.toList aurAlreadyRegistered)
  aurAlreadyTutorialMember' <- fmap sort (lift . mapM getJust $ Set.toList aurAlreadyTutorialMember)

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

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


registerUser :: CourseId
             -> (Text, Maybe UserId)
             -> WriterT AddParticipantsResult (YesodJobDB UniWorX) ()
registerUser _cid ( avsIdent, Nothing ) = tell $ mempty { aurNotFound = Set.singleton avsIdent }
registerUser  cid (_avsIdent, Just 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 -- TODO: send Notification at all?

  return $ mempty { aurRegisterSuccess = Set.singleton uid }