-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.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 qualified Data.Aeson as Aeson
import qualified Data.CaseInsensitive as CI
import Data.Map ((!))
import qualified Data.Map as Map
import qualified Data.Time.Zones as TZ
import qualified Data.Set as Set

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

import Generics.Deriving.Monoid (memptydefault, mappenddefault)


type UserSearchKey = Text
type TutorialIdent = CI Text


data ButtonCourseRegisterMode = BtnCourseRegisterConfirm | BtnCourseRegisterAbort
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonCourseRegisterMode
instance Finite ButtonCourseRegisterMode

embedRenderMessage ''UniWorX ''ButtonCourseRegisterMode id

nullaryPathPiece ''ButtonCourseRegisterMode $ camelToPathPiece' 1

instance Button UniWorX ButtonCourseRegisterMode where
  btnLabel x = [whamlet|_{x}|]
  btnClasses BtnCourseRegisterConfirm = [BCIsButton, BCPrimary]
  btnClasses BtnCourseRegisterAbort   = [BCIsButton, BCDanger]
  btnValidate _ BtnCourseRegisterAbort = False
  btnValidate _ _                      = True


data CourseRegisterAction
   = CourseRegisterActionAddParticipant
   | CourseRegisterActionAddTutorialMember
-- | CourseRegisterActionUnknownPerson
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe CourseRegisterAction
instance Finite CourseRegisterAction

data CourseRegisterActionData
   = CourseRegisterActionAddParticipantData
     { crActIdent    :: UserSearchKey
     , crActUser     :: (UserId, User)
     }
   | CourseRegisterActionAddTutorialMemberData
     { crActIdent    :: UserSearchKey
     , crActUser     :: (UserId, User)
     , crActTutorial :: TutorialIdent
     }
-- | CourseRegisterActionUnknownPersonData -- pseudo-action; just for display
--   { crActUnknownPersonIdent :: Text
--   }
   deriving (Eq, Ord, Show, Generic, Typeable)

makeLenses_ ''CourseRegisterActionData
makePrisms ''CourseRegisterActionData

instance Aeson.FromJSON CourseRegisterActionData where
  parseJSON = Aeson.genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 2 }

instance Aeson.ToJSON CourseRegisterActionData where
  toJSON = Aeson.genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 2 }
  toEncoding = Aeson.genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 2 }

_classifyRegisterAction :: CourseRegisterActionData -> CourseRegisterAction
_classifyRegisterAction = \case
  CourseRegisterActionAddParticipantData{}    -> CourseRegisterActionAddParticipant
  CourseRegisterActionAddTutorialMemberData{} -> CourseRegisterActionAddTutorialMember
--CourseRegisterActionUnknownPersonData{}     -> CourseRegisterActionUnknownPerson

courseRegisterRenderActionClass :: CourseRegisterAction -> Widget
courseRegisterRenderActionClass = \case
  CourseRegisterActionAddParticipant    -> [whamlet|_{MsgCourseParticipantsRegisterActionAddParticipants}|]
  CourseRegisterActionAddTutorialMember -> [whamlet|_{MsgCourseParticipantsRegisterActionAddTutorialMembers}|]

courseRegisterRenderAction :: CourseRegisterActionData -> Widget
courseRegisterRenderAction act = [whamlet|^{userWidget (view _2 (crActUser act))} (#{crActIdent act})|]


data AddUserRequest = AddUserRequest
  { auReqUsers    :: Set UserSearchKey
  , auReqTutorial :: Maybe TutorialIdent
  } deriving (Eq, Ord, Read, Show, Generic, Typeable)


data AddParticipantsResult = AddParticipantsResult
  { aurNotFound              :: Set UserSearchKey
  , 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
  currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute

  confirmedActs :: Set CourseRegisterActionData <- fmap Set.fromList . throwExceptT . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction
  $logDebugS "CAddUserR confirmedActs" . tshow $ Set.map Aeson.encode confirmedActs
  unless (Set.null confirmedActs) $ do -- TODO: check that all acts are member of availableActs
    let
      users = Map.fromList . fmap (\act -> (crActIdent act, Just . view _1 $ crActUser act)) $ Set.toList confirmedActs
      tutActs = Set.filter (is _CourseRegisterActionAddTutorialMemberData) confirmedActs
      actTutorial = crActTutorial <$> Set.lookupMin tutActs -- tutorial ident must be the same for every added member!
    registeredUsers <- registerUsers cid users
    forM_ actTutorial $ \tutName -> do
      tutId <- upsertNewTutorial cid tutName
      registerTutorialMembers tutId registeredUsers

    if
      | Just tutName <- actTutorial
      , Set.size tutActs == Set.size confirmedActs
        -> redirect $ CTutorialR tid ssh csh tutName TUsersR
      | otherwise
        -> redirect $ CourseR tid ssh csh CUsersR

  ((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do
    today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
    auReqUsers <- wreq (textField & cfCommaSeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty
    auReqTutorial <- optionalActionW
      ( areq (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just . CI.mk $ tshow today) ) -- TODO: use user date display setting
      ( fslI MsgCourseParticipantsRegisterTutorialOption )
      ( Just True )
    return $ AddUserRequest <$> auReqUsers <*> auReqTutorial

  formResult usersToAdd $ \AddUserRequest{..} -> do
    avsUsers :: Map UserSearchKey (Maybe UserId) <- sequenceA $ Map.fromSet upsertAvsUser auReqUsers
    let (usersFound, usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
    unless (null usersNotFound) $
      let msgContent = [whamlet|
            $newline never
            <ul>
              $forall (usr,_) <- usersNotFound
                <li>#{usr}
            |]
       in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
    when (null usersFound) $
      redirect currentRoute

    liftHandler . (>>= sendResponse) $
      siteLayoutMsg MsgCourseParticipantsRegisterHeading $ do
        setTitleI MsgCourseParticipantsRegisterHeading

        actionMap :: Map CourseRegisterAction (Set CourseRegisterActionData) <- fmap (Map.unionsWith Set.union) . forM usersFound $ \case
          (_, Nothing) -> error "Found user in AVS, but response is Nothing!" -- this should not be possible
          (ukey, Just uid) -> do
            -- isParticipant <- exists [CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive]
            user <- liftHandler . runDBRead $ get404 uid
            case auReqTutorial of
              Nothing -> return . Map.singleton CourseRegisterActionAddParticipant . Set.singleton $ CourseRegisterActionAddParticipantData ukey (uid,user)
              Just crActAddTutorialMemberTutorial -> return . Map.singleton CourseRegisterActionAddTutorialMember . Set.singleton $ CourseRegisterActionAddTutorialMemberData ukey (uid,user) crActAddTutorialMemberTutorial

        let
          precomputeIdents :: forall f m. (Eq (Element f), MonoFoldable f, MonadHandler m) => f -> m (Element f -> Text)
          precomputeIdents = foldM (\f act -> (\id' x -> bool (f x) id' $ act == x) <$> newIdent) (\_ -> error "No id precomputed")
        actionClassIdent <- precomputeIdents $ Map.keys actionMap
        actionIdent <- precomputeIdents . Set.unions $ Map.elems actionMap

        let
          confirmCheckBox :: [(Text,Text)] -> CourseRegisterActionData -> Widget
          confirmCheckBox vAttrs act = do
            let
              sJsonField :: Field (HandlerFor UniWorX) CourseRegisterActionData
              sJsonField = secretJsonField' $ \theId name attrs val _isReq ->
                [whamlet|
                  $newline never
                  <input id=#{theId} *{attrs} type=checkbox name=#{name} value=#{either id id val} checked>
                |]
            fieldView sJsonField (actionIdent act) (toPathPiece PostCourseUserAddConfirmAction) vAttrs (Right act) False
          availableActs :: Widget
          availableActs = fieldView (secretJsonField :: Field Handler (Set CourseRegisterActionData)) "" (toPathPiece PostCourseUserAddConfirmAvailableActions) [] (Right . Set.unions $ Map.elems actionMap) False
        (confirmForm', confirmEnctype) <- generateFormPost . withButtonForm' [BtnCourseRegisterConfirm, BtnCourseRegisterAbort] . identifyForm FIDCourseRegisterConfirm $ \csrf -> return (error "No meaningful FormResult", $(widgetFile "course/add-user/confirmation"))
        let confirmForm = wrapForm confirmForm' FormSettings
              { formMethod   = POST
              , formAction   = Just . SomeRoute $ CourseR tid ssh csh CAddUserR
              , formEncoding = confirmEnctype
              , formAttrs    = []
              , formSubmit   = FormNoSubmit
              , formAnchor   = Nothing :: Maybe Text
              }
        $(widgetFile "course/add-user/confirmation-wrapper")

  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 UserSearchKey (Maybe UserId) -> Handler (Set UserId)
registerUsers cid users
  | Map.null users = do
    addMessageI Error MsgCourseParticipantsRegisterNoneGiven
    return Set.empty
  | otherwise = do
    (mconcat -> AddParticipantsResult{..}) <- runDBJobs . mapM (registerUser cid) $ Map.toList users
    unless (Set.null aurRegisterSuccess) $
      addMessageI Success . MsgCourseParticipantsRegistered $ Set.size aurRegisterSuccess
    unless (Set.null aurAlreadyRegistered) $
      addMessageI Info . MsgCourseParticipantsAlreadyRegistered $ Set.size aurAlreadyRegistered
    return $ aurRegisterSuccess `Set.union` aurAlreadyRegistered

registerUser :: CourseId
             -> (UserSearchKey, Maybe UserId)
             -> YesodJobDB UniWorX AddParticipantsResult
registerUser _cid ( avsIdent, Nothing ) = return $ mempty { aurNotFound = Set.singleton avsIdent }
registerUser  cid (_avsIdent, Just uid) = exceptT return return $ do
  whenM (lift $ exists [CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive]) $
    throwError $ mempty { aurAlreadyRegistered = Set.singleton uid }

  courseParticipantRegistration <- liftIO getCurrentTime
  void . lift $ upsert
    CourseParticipant -- TODO: use participantId instead of userId for aurRegisterSuccess
      { courseParticipantCourse = cid
      , courseParticipantUser = uid
      , courseParticipantState = CourseParticipantActive
      , ..
      }
    [ CourseParticipantRegistration =. courseParticipantRegistration
    , CourseParticipantState =. CourseParticipantActive
    ]
  lift . audit $ TransactionCourseParticipantEdit cid uid
  lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid

  return $ mempty { aurRegisterSuccess = Set.singleton uid }

upsertNewTutorial :: CourseId -> TutorialIdent -> Handler TutorialId
upsertNewTutorial cid tutorialName = do
  now <- liftIO getCurrentTime
  runDB $ do
    Entity tutId _ <- upsert
      Tutorial
        { tutorialCourse = cid
        , tutorialType = CI.mk "Schulung"
        , 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
      , TutorialType        =. CI.mk "Schulung"
      , TutorialLastChanged =. now
      ]
    audit $ TransactionTutorialEdit tutId
    return tutId

registerTutorialMembers :: TutorialId -> Set UserId -> Handler ()
registerTutorialMembers tutId (Set.toList -> users) = runDB $ do
  prevParticipants <- Set.fromList . fmap entityKey <$> selectList [TutorialParticipantUser <-. users, TutorialParticipantTutorial ==. tutId] []
  participants <- fmap Set.fromList . for users $ \tutorialParticipantUser -> do
    Entity tutPartId _ <- upsert TutorialParticipant { tutorialParticipantTutorial = tutId, .. } []
    audit $ TransactionTutorialParticipantEdit tutId tutPartId tutorialParticipantUser
    return tutPartId
  let newParticipants = participants Set.\\ prevParticipants
  unless (Set.null newParticipants) $
    addMessageI Success . MsgCourseParticipantsRegisteredTutorial $ Set.size newParticipants
  unless (Set.null prevParticipants) $
    addMessageI Info . MsgCourseParticipantsAlreadyTutorialMember $ length prevParticipants