-- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# LANGUAGE TypeApplications #-}

module Handler.Course.ParticipantInvite
  ( getCAddUserR, postCAddUserR
  , getTAddUserR, postTAddUserR
  ) 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 qualified Data.Text as Text

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

import Generics.Deriving.Monoid (memptydefault, mappenddefault)

-- import           Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils        as E

import Utils.Occurrences


type UserSearchKey = Text
type TutorialType  = CI Text

defaultTutorialType :: TutorialType
defaultTutorialType = "Schulung"

tutorialTypeSeparator :: TutorialType
tutorialTypeSeparator = "_"

tutorialTemplateNames :: Maybe TutorialType -> [TutorialType]
tutorialTemplateNames Nothing     = ["Vorlage", "Template"]
tutorialTemplateNames (Just name) = [prefixes <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- [mempty, tutorialTypeSeparator <> name]]

tutorialDefaultName :: Maybe TutorialType -> Day -> TutorialName
tutorialDefaultName Nothing     = formatDayForTutName 
tutorialDefaultName (Just ttyp) = 
  let prefix = CI.mk $ snd $ Text.breakOnEnd (CI.original tutorialTypeSeparator) $ CI.original ttyp
  in  (<> (tutorialTypeSeparator <> prefix)) . tutorialDefaultName Nothing

formatDayForTutName :: Day -> CI Text -- "%yy_%mm_%dd" -- Do not use user date display setting, since tutorial default names must be universal regardless of user
-- formatDayForTutName = CI.mk . formatTime' "%y_%m_%d" -- we don't want to go monadic for this
formatDayForTutName = CI.mk . Text.map d2u . Text.drop 2 . tshow 
  where 
    d2u '-' = '_'
    d2u  c  =  c


data ButtonCourseRegisterMode = BtnCourseRegisterConfirm | BtnCourseRegisterAbort
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
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)
instance Universe CourseRegisterAction
instance Finite CourseRegisterAction

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

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 (Maybe TutorialName, Maybe TutorialType, Maybe Day)
  } deriving (Eq, Ord, Read, Show, Generic)


data AddParticipantsResult = AddParticipantsResult
  { aurNotFound              :: Set UserSearchKey
  , aurAlreadyRegistered
  , aurAlreadyTutorialMember
  , aurRegisterSuccess
  , aurTutorialSuccess       :: Set UserId
  } deriving (Read, Show, Generic)

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 
  today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
  handleAddUserR tid ssh csh (Right today) Nothing
  -- postTAddUserR tid ssh csh (CI.mk $ tshow today)  -- Don't use user date display setting, so that tutorial default names conform to all users


getTAddUserR,  postTAddUserR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
getTAddUserR = postTAddUserR
postTAddUserR tid ssh csh tutn = handleAddUserR tid ssh csh (Left tutn) Nothing


handleAddUserR :: TermId -> SchoolId -> CourseShorthand -> Either TutorialName Day -> Maybe TutorialType -> Handler Html
handleAddUserR tid ssh csh tdesc ttyp = do 
  (cid, tutTypes, tutNameSuggestions) <- runDB $ do 
    let plainTemplates = tutorialTemplateNames Nothing
    cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
    tutTypes <- E.select $ E.distinct $ do
      tutorial <- E.from $ E.table @Tutorial
      let tuTyp = tutorial E.^. TutorialType
      E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
      E.orderBy [E.asc tuTyp]
      return tuTyp
    let typeSet = Set.fromList  [ maybe t CI.mk $ Text.stripPrefix temp_sep $ CI.original t
                                | temp <- plainTemplates
                                , let temp_sep = CI.original (temp <> tutorialTypeSeparator)
                                , E.Value t <- tutTypes                    
                                ]
    tutNames <- E.select $ do 
      tutorial <- E.from $ E.table @Tutorial
      let tuName = tutorial E.^. TutorialName
      E.where_ $  tutorial E.^. TutorialCourse E.==. E.val cid
          E.&&.   E.isJust (tutorial E.^. TutorialFirstDay)
          E.&&.   E.not_ (E.any (E.hasPrefix_ (tutorial E.^. TutorialType) . E.val) plainTemplates)
      E.orderBy [E.desc $ tutorial E.^. TutorialFirstDay, E.asc tuName]
      E.limit 7
      return tuName
    let tutNameSuggestions = return $ mkOptionList [Option tno tn tno | etn <- tutNames, let tn = E.unValue etn, let tno = CI.original tn]
    return (cid, Set.toAscList typeSet, tutNameSuggestions) -- Set in order to remove duplicates and sort ascending at once

  currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute

  (_ , registerConfirmResult) <- runButtonForm FIDCourseRegisterConfirm    
  --   $logDebugS "***AbortProblem***" $ tshow registerConfirmResult
  prefillUsers <- case registerConfirmResult of 
    Nothing -> return mempty
    (Just BtnCourseRegisterAbort)   -> do 
      addMessageI Warning MsgAborted
      -- prefill confirmed users for convenience. Note that Browser-Back may also return to the filled form, but history.back() does not in Chrome
      confirmedActs :: [CourseRegisterActionData] <- exceptT (const $ return mempty) return . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction  -- ignore any exception, since it is only used to prefill a form field for convenience
      return $ Just $ Set.fromList $ fmap crActIdent confirmedActs
    (Just BtnCourseRegisterConfirm) -> do
      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
        whenIsJust actTutorial $ \(tutName,tutType,tutDay) -> do
          whenIsJust (tutName <|> fmap (tutorialDefaultName tutType) tutDay) $ \tName -> do
            tutId <- upsertNewTutorial cid tName tutType tutDay
            registerTutorialMembers tutId registeredUsers
            -- when (Set.size tutActs == Set.size confirmedActs) $ -- not sure how this condition might be false at this point
            redirect $ CTutorialR tid ssh csh tName TUsersR
        redirect $ CourseR tid ssh csh CUsersR
      return mempty
  
  ((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . identifyForm FIDCourseRegister . renderWForm FormStandard $ do
    let tutTypesMsg   = [(SomeMessage tt,tt) | tt <- tutTypes]
        tutDefType    = ttyp >>= (\ty -> if ty `elem` tutTypes then Just ty else Nothing)        
    auReqUsers <- wreq (textField & cfAnySeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) prefillUsers
    auReqTutorial <- optionalActionW
      ( (,,) 
        <$> aopt  (textField & cfStrip & cfCI & addDatalist tutNameSuggestions)
                  (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip)
                  (Just $ maybeLeft tdesc)
        <*> aopt  (selectFieldList tutTypesMsg)
                  (fslI MsgTableTutorialType)
                  (Just tutDefType)
        <*> aopt   dayField
                  (fslI MsgTableTutorialFirstDay & setTooltip MsgCourseParticipantsRegisterTutorialFirstDayTip)
                  (Just $ maybeRight tdesc)
      )
      ( fslI MsgCourseParticipantsRegisterTutorialOption )
      ( Just True )
    return $ AddUserRequest <$> auReqUsers <*> auReqTutorial

  formResult usersToAdd $ \AddUserRequest{..} -> do
    avsUsers :: Map UserSearchKey (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser 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 -> TutorialName -> Maybe TutorialType -> Maybe Day -> Handler TutorialId
upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do
  now <- liftIO getCurrentTime
  existingTut <- getBy $ UniqueTutorial cid newTutorialName
  templateEnt <- selectFirst [TutorialType <-. tutorialTemplateNames newTutorialType] [Desc TutorialType, Asc TutorialName]
  case (existingTut, newFirstDay, templateEnt) of
    (Just Entity{entityKey=tid},_,_) -> return tid -- no need to update, we ignore the anchor day 
    (Nothing, Just moveDay, Just Entity{entityVal=Tutorial{..}}) -> do
      Course{..} <- get404 cid
      term <- get404 courseTerm
      let oldFirstDay = fromMaybe moveDay $ tutorialFirstDay <|> fst (occurrencesBounds term tutorialTime)
          newTime     = normalizeOccurrences $ occurrencesAddBusinessDays term (oldFirstDay, moveDay) tutorialTime          
          dayDiff   = maybe 0 (diffDays moveDay) tutorialFirstDay
          mvTime    = fmap $ addLocalDays dayDiff
          newType0  = CI.map (snd . Text.breakOnEnd (CI.original tutorialTypeSeparator)) tutorialType
          newType   = if newType0 `elem` tutorialTemplateNames Nothing
                        then fromMaybe defaultTutorialType newTutorialType
                        else newType0
      Entity tutId _ <- upsert
        Tutorial
          { tutorialName            = newTutorialName
          , tutorialCourse          = cid
          , tutorialType            = newType
          , tutorialFirstDay        = newFirstDay
          , tutorialTime            = newTime
          , tutorialRegisterFrom    = mvTime tutorialRegisterFrom
          , tutorialRegisterTo      = mvTime tutorialRegisterTo
          , tutorialDeregisterUntil = mvTime tutorialDeregisterUntil
          , tutorialLastChanged     = now
          , ..
          } [] -- update cannot happen due to previous case      
      audit $ TransactionTutorialEdit tutId
      return tutId
    _ -> do
      Entity tutId _ <- upsert
        Tutorial
          { tutorialName            = newTutorialName
          , tutorialCourse          = cid
          , tutorialType            = fromMaybe defaultTutorialType newTutorialType
          , tutorialCapacity        = Nothing
          , tutorialRoom            = Nothing
          , tutorialRoomHidden      = False
          , tutorialTime            = Occurrences mempty mempty
          , tutorialRegGroup        = Nothing
          , tutorialRegisterFrom    = Nothing
          , tutorialRegisterTo      = Nothing
          , tutorialDeregisterUntil = Nothing
          , tutorialLastChanged     = now
          , tutorialTutorControlled = False
          , tutorialFirstDay        = Nothing
          } [] -- update cannot happen due to previous cases      
      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
