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

module Handler.Course.ParticipantInvite
  ( InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
  , getCInviteR, postCInviteR
  , getCAddUserR, postCAddUserR
  , AddParticipantsResult(..)
  , addParticipantsResultMessages
  , registerUsers, registerUser
  , registerUsers', registerUser'
  ) where

import Import

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

import qualified Data.CaseInsensitive as CI

import qualified Data.Set as Set
import qualified Data.Map as Map

import Jobs.Queue

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

import Text.Hamlet (ihamlet)

import Control.Monad.Except (MonadError(..))

import Generics.Deriving.Monoid (memptydefault, mappenddefault)

import qualified Data.HashSet as HashSet


-- Invitations for ordinary participants of this course
instance IsInvitableJunction CourseParticipant where
  type InvitationFor CourseParticipant = Course
  data InvitableJunction CourseParticipant = JunctionParticipant
    { jParticipantRegistration :: UTCTime
    , jParticipantAllocated    :: Maybe AllocationId
    , jParticipantState        :: CourseParticipantState
    } 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
    { invTokenParticipantSubmissionGroup :: Maybe SubmissionGroupName
    }
    deriving (Eq, Ord, Read, Show, Generic, Typeable)

  _InvitableJunction = iso
    (\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantAllocated courseParticipantState))
    (\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantAllocated courseParticipantState) -> 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 { fieldLabelModifier = camelToPathPiece' 3, omitNothingFields = True }
  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3, omitNothingFields = True }
instance FromJSON (InvitationTokenData CourseParticipant) where
  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3, omitNothingFields = True }

participantInvitationConfig :: InvitationConfig CourseParticipant
participantInvitationConfig = InvitationConfig{..}
  where
    invitationRoute (Entity _ Course{..}) _ = return $ CourseR courseTerm courseSchool courseShorthand CInviteR
    invitationResolveFor _ = do
      cRoute <- getCurrentRoute
      case cRoute of
        Just (CourseR tid csh ssh CInviteR) ->
          getKeyBy404 $ TermSchoolCourseShort tid csh ssh
        _other ->
          error "participantInvitationConfig called from unsupported route"
    invitationSubject     (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand
    invitationHeading     (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
    invitationExplanation  _                    _ = return [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
    invitationTokenConfig _ _ = do
      itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
      return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
    invitationRestriction _ _ = return Authorized
    invitationForm _ _ _ = hoistAForm lift . wFormToAForm $ do
      now <- liftIO getCurrentTime
      return . pure . (, ()) $ JunctionParticipant now Nothing CourseParticipantActive
    invitationInsertHook _ _ (_, InvTokenDataParticipant{..}) CourseParticipant{..} _ act = do
      deleteBy $ UniqueParticipant courseParticipantUser courseParticipantCourse -- there are no foreign key references to @{CourseParticipant}; therefor we can delete and recreate to simulate upsert
      res <- act -- insertUnique
      audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser
      void $ setUserSubmissionGroup courseParticipantCourse courseParticipantUser invTokenParticipantSubmissionGroup
      return res
    invitationSuccessMsg (Entity _ Course{..}) _ =
      return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName)
    invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR

data AddParticipantsResult = AddParticipantsResult
  { aurAlreadyRegistered
  , aurSuccess              :: 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
    ((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do
      enlist <- wreq checkBoxField (fslI MsgCourseParticipantEnlistDirectly) (Just False)

      let submissionGroupOpts = optionsPersist [SubmissionGroupCourse ==. cid] [Asc SubmissionGroupName] submissionGroupName <&> fmap (submissionGroupName . entityVal)
      mbGrp <- wopt (textField & cfStrip & cfCI & addDatalist submissionGroupOpts) (fslI MsgSubmissionGroup & setTooltip MsgSubmissionGroupEmptyIsUnsetTip) Nothing

      mr <- getMessageRender
      users <- wreq (multiUserInvitationField . maybe MUIAlwaysInvite (const $ MUILookupAnyUser Nothing) $ formResultToMaybe enlist)
                 (fslpI MsgCourseParticipantInviteField (mr MsgLdapIdentificationOrEmail) & setTooltip MsgMultiEmailFieldTip) Nothing

      return $ Map.fromSet . const <$> mbGrp <*> users

    formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $
      hoist runDBJobs . registerUsers' 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
        }

registerUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] (YesodJobDB UniWorX) ()
registerUsers cid = registerUsers' cid . Map.fromSet (const Nothing)

registerUsers' :: CourseId -> Map (Either UserEmail UserId) (Maybe SubmissionGroupName) -> WriterT [Message] (YesodJobDB UniWorX) ()
registerUsers' cid users = do
  let (emails,uids) = partitionKeysEither users

  -- send Invitation eMails to unkown users
  lift $ sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant{..})) | (mail, invTokenParticipantSubmissionGroup) <- Map.toList emails]
  -- register known users
  tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT $ imapM_ (registerUser' cid) uids

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


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)

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


registerUser :: CourseId
             -> UserId
             -> WriterT AddParticipantsResult (YesodJobDB UniWorX) ()
registerUser cid uid = registerUser' cid uid Nothing

registerUser' :: CourseId
              -> UserId
              -> Maybe SubmissionGroupName
              -> WriterT AddParticipantsResult (YesodJobDB UniWorX) ()
registerUser' cid uid mbGrp = 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

  void . lift . lift $ setUserSubmissionGroup cid uid mbGrp

  return $ mempty { aurSuccess = Set.singleton uid }


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