-- 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.Text as Text
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
     { crActAddParticipantIdent       :: UserSearchKey
     , crActAddParticipantUser        :: (UserId, User)
     }
   | CourseRegisterActionAddTutorialMemberData
     { crActAddTutorialMemberIdent    :: UserSearchKey
     , crActAddTutorialMemberUser     :: (UserId, User)
     , crActAddTutorialMemberTutorial :: TutorialIdent
     }
-- | CourseRegisterActionUnknownPersonData -- pseudo-action; just for display
--   { crActUnknownPersonIdent :: Text
--   }
   deriving (Eq, Ord, Show, Generic, Typeable)

makeLenses_ ''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 = \case
  CourseRegisterActionAddParticipantData{..}    -> [whamlet|^{userWidget (view _2 crActAddParticipantUser)} (#{crActAddParticipantIdent})|]
  CourseRegisterActionAddTutorialMemberData{..} -> [whamlet|^{userWidget (view _2 crActAddTutorialMemberUser)} (#{crActAddTutorialMemberIdent}), _{MsgCourseParticipantsRegisterTutorialField}: #{crActAddTutorialMemberTutorial}|]


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

  confirmAvailableActs <- fmap (maybe FormMissing FormSuccess) . throwExceptT . runMaybeT $ encodedSecretBoxOpen =<< MaybeT (lift . lookupPostParam $ toPathPiece PostCourseUserAddConfirmAvailableActions)
  confirmActs <- fmap (maybe FormMissing FormSuccess) . throwExceptT . runMaybeT $ encodedSecretBoxOpen =<< MaybeT (lift . lookupPostParam $ toPathPiece PostCourseUserAddConfirmAction)
  $logErrorS "CAddUserR available" . tshow $ Aeson.encode (confirmAvailableActs :: Maybe (Set CourseRegisterActionData))
  $logErrorS "CAddUserR acts" . tshow $ Aeson.encode (confirmActs :: Maybe (Set CourseRegisterActionData))
  if
    | FormSuccess acts           <- confirmActs
    , FormSuccess _availableActs <- confirmAvailableActs
      -> do
           -- TODO: check that all acts are member of availableActs!
           forM_ (Set.toList acts) $ \case
             CourseRegisterActionAddTutorialMemberData{..} -> do
               registeredUsers <- registerUsers cid $ Map.singleton crActAddTutorialMemberIdent (Just $ view _1 crActAddTutorialMemberUser)
               tutId <- upsertNewTutorial cid crActAddTutorialMemberTutorial
               registerTutorialMembers tutId registeredUsers
               redirect $ CTutorialR tid ssh csh crActAddTutorialMemberTutorial TUsersR
             CourseRegisterActionAddParticipantData{..} -> do
               void . registerUsers cid $ Map.singleton crActAddParticipantIdent (Just $ view _1 crActAddParticipantUser)
               redirect $ CourseR tid ssh csh CUsersR
    | FormSuccess _    <- confirmActsRes
      -> addMessageI Error MsgCourseParticipantsRegisterConfirmInvalid
    | FormMissing      <- confirmActsRes
      -> return ()
    | FormFailure errs <- confirmActsRes
      -> forM_ errs $ addMessage Error . toHtml

  ((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do
    today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
    let
      cfCommaSeparatedSet :: forall m. Functor m => Field m Text -> Field m (Set Text)
      cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.splitOn ",") (Text.intercalate ", " . Set.toList)
    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
      , courseParticipantAllocated = Nothing
      , courseParticipantState = CourseParticipantActive
      , ..
      }
    [ CourseParticipantRegistration =. courseParticipantRegistration
    , CourseParticipantAllocated =. Nothing
    , CourseParticipantState =. CourseParticipantActive
    ]
  lift . audit $ TransactionCourseParticipantEdit cid uid
  lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid -- TODO: send Notification at all?

  return $ mempty { aurRegisterSuccess = Set.singleton uid }

upsertNewTutorial :: CourseId -> TutorialIdent -> Handler TutorialId
upsertNewTutorial cid tutorialName = do
  now <- liftIO getCurrentTime
  Entity tutId _ <- runDB $ upsert
    Tutorial
      { tutorialCourse = cid
      , tutorialType = CI.mk mempty -- TODO: remove type? unneeded?
      , 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
    , TutorialLastChanged =. now
    ]
  return tutId

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