fradrive-old/src/Handler/Course/ParticipantInvite.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Handler.Course.ParticipantInvite
  ( InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
  , getCInviteR, postCInviteR
  , getCAddUserR, postCAddUserR
  ) where

import Import

import Utils.Form
import Handler.Utils
import Handler.Utils.Invitations

import qualified Data.CaseInsensitive as CI
import Data.Function ((&))

import qualified Data.Set as Set

import Jobs.Queue

import Data.Aeson hiding (Result(..))

import Text.Hamlet (ihamlet)

import Control.Monad.Trans.Writer (WriterT, execWriterT)
import Control.Monad.Except (MonadError(..))

import Generics.Deriving.Monoid (memptydefault, mappenddefault)


-- Invitations for ordinary participants of this course
instance IsInvitableJunction CourseParticipant where
  type InvitationFor CourseParticipant = Course
  data InvitableJunction CourseParticipant = JunctionParticipant
    { jParticipantRegistration :: UTCTime
    , jParticipantField        :: Maybe StudyFeaturesId
    , jParticipantAllocated    :: Bool
    } deriving (Eq, Ord, Read, Show, Generic, Typeable)
  data InvitationDBData CourseParticipant = InvDBDataParticipant
    -- no data needed in DB to manage participant invitation
    deriving (Eq, Ord, Read, Show, Generic, Typeable)
  data InvitationTokenData CourseParticipant = InvTokenDataParticipant
    deriving (Eq, Ord, Read, Show, Generic, Typeable)

  _InvitableJunction = iso
    (\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated))
    (\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated) -> CourseParticipant{..})

instance ToJSON (InvitableJunction CourseParticipant) where
  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
instance FromJSON (InvitableJunction CourseParticipant) where
  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }

instance ToJSON (InvitationDBData CourseParticipant) where
  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
instance FromJSON (InvitationDBData CourseParticipant) where
  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }

instance ToJSON (InvitationTokenData CourseParticipant) where
  toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
instance FromJSON (InvitationTokenData CourseParticipant) where
  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }

participantInvitationConfig :: InvitationConfig CourseParticipant
participantInvitationConfig = InvitationConfig{..}
  where
    invitationRoute (Entity _ Course{..}) _ = return $ CourseR courseTerm courseSchool courseShorthand CInviteR
    invitationResolveFor _ = do
      Just (CourseR tid csh ssh CInviteR) <- getCurrentRoute
      getKeyBy404 $ TermSchoolCourseShort tid csh ssh
    invitationSubject     (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand
    invitationHeading     (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
    invitationExplanation _          _ = [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
    invitationTokenConfig _ _ = do
      itAuthority <- liftHandlerT requireAuthId
      return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
    invitationRestriction _ _ = return Authorized
    invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do
      now <- liftIO getCurrentTime
      studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid)
          (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing
      return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure False
    invitationInsertHook _ _ CourseParticipant{..} _ act = do
      res <- act
      audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser
      return res
    invitationSuccessMsg (Entity _ Course{..}) _ =
      return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName)
    invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR

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

instance Monoid AddRecipientsResult where
  mempty = memptydefault
  mappend = mappenddefault

getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCAddUserR = postCAddUserR
postCAddUserR tid ssh csh = do
    cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
    ((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do
      enlist <- wreq checkBoxField (fslI MsgCourseParticipantEnlistDirectly) (Just False)
      wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing)
              (fslI MsgCourseParticipantInviteField & setTooltip MsgMultiEmailFieldTip) Nothing

    formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $ processUsers cid

    let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading

    siteLayoutMsg heading $ do
      setTitleI heading
      wrapForm formWgt def
        { formEncoding
        , formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR
        }
  where
    processUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] Handler ()
    processUsers cid users = do
      let (emails,uids) = partitionEithers $ Set.toList users
      AddRecipientsResult{..} <- lift . runDBJobs $ do
        -- send Invitation eMails to unkown users
        sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant)) | mail <- emails]
        -- register known users
        execWriterT $ mapM (registerUser cid) uids

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

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

      unless (null aurNoUniquePrimaryField) $ do
        let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisteredWithoutField (length aurNoUniquePrimaryField)}|]
            modalContent = $(widgetFile "messages/courseInvitationRegisteredWithoutField")
        tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent)

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

    registerUser :: CourseId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) ()
    registerUser cid uid = exceptT tell tell $ do
      User{..} <- lift . lift $ getJust uid

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

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

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

      courseParticipantRegistration <- liftIO getCurrentTime
      void . lift . lift . insert $ CourseParticipant
        { courseParticipantCourse = cid
        , courseParticipantUser = uid
        , courseParticipantAllocated = False
        , ..
        }
      lift . lift . audit $ TransactionCourseParticipantEdit cid uid

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


getCInviteR, postCInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCInviteR = postCInviteR
postCInviteR = invitationR participantInvitationConfig