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

module Handler.Course.ParticipantInvite
  ( InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
  , getCInviteR, postCInviteR
  , getCAddUserR, postCAddUserR
  , AddParticipantsResult(..)
  , addParticipantsResultMessages
  , registerUsers, registerUser
  ) 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    :: Maybe AllocationId
    } 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
      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 <- liftHandler 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 Nothing
    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 AddParticipantsResult = AddParticipantsResult
  { aurAlreadyRegistered
  , aurNoUniquePrimaryField
  , 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)
      wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing)
              (fslI MsgCourseParticipantInviteField & setTooltip MsgMultiEmailFieldTip) Nothing

    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 users = do
  let (emails,uids) = partitionEithers $ Set.toList users

  -- send Invitation eMails to unkown users
  lift $ sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant)) | mail <- emails]
  -- register known users
  tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT $ mapM_ (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', aurNoUniquePrimaryField') <- 
    (,) <$> fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurAlreadyRegistered)
        <*> fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurNoUniquePrimaryField)

  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 AddParticipantsResult (YesodJobDB UniWorX) ()
registerUser cid uid = exceptT tell tell $ do
  whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $
    throwError $ mempty { aurAlreadyRegistered = Set.singleton uid }

  features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] []
  applications <- lift . lift $ selectList [ CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] []

  let courseParticipantField
        | [f] <- features
        = Just f
        | [f'] <- nub $ mapMaybe (courseApplicationField . entityVal) applications
        , f' `elem` features
        = Just f'
        | otherwise
        = Nothing

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

  return $ case courseParticipantField of
    Nothing -> mempty { aurNoUniquePrimaryField = Set.singleton uid }
    Just _  -> mempty { aurSuccess              = Set.singleton uid }


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