module Handler.Course.Register
  ( ButtonCourseRegister(..)
  , CourseRegisterForm(..)
  , courseRegisterForm, courseMayReRegister
  , getCRegisterR, postCRegisterR
  , deregisterParticipant
  ) where

import Import

import Handler.Utils
import Handler.Utils.Exam

import Utils.Course

import qualified Data.Text as Text

import qualified Data.Conduit.List as C

import Database.Persist.Sql (transactionUndo)
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E


-- Dedicated CourseRegistrationButton
data ButtonCourseRegister = BtnCourseRegister | BtnCourseDeregister | BtnCourseApply | BtnCourseRetractApplication
  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonCourseRegister
instance Finite ButtonCourseRegister
nullaryPathPiece ''ButtonCourseRegister $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''ButtonCourseRegister id
instance Button UniWorX ButtonCourseRegister where
  btnClasses BtnCourseRegister           = [BCIsButton, BCPrimary]
  btnClasses BtnCourseDeregister         = [BCIsButton, BCDanger]
  btnClasses BtnCourseApply              = [BCIsButton, BCPrimary]
  btnClasses BtnCourseRetractApplication = [BCIsButton, BCDanger]

  btnLabel   BtnCourseRegister           = [whamlet|#{iconEnrol True}  _{MsgBtnCourseRegister}|]
  btnLabel   BtnCourseDeregister         = [whamlet|#{iconEnrol False} _{MsgBtnCourseDeregister}|]
  btnLabel   BtnCourseApply              = [whamlet|#{iconApply True}  _{MsgBtnCourseApply}|]
  btnLabel   BtnCourseRetractApplication = [whamlet|#{iconApply False} _{MsgBtnCourseRetractApplication}|]


data CourseRegisterForm = CourseRegisterForm
  { crfApplicationText  :: Maybe Text
  , crfApplicationFiles :: Maybe FileUploads
  }

courseRegisterForm :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Course -> m (AForm Handler CourseRegisterForm, ButtonCourseRegister)
-- ^ `CourseRegisterForm` for current user
courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
  muid <- maybeAuthId
  ata <- getSessionActiveAuthTags
  now <- liftIO getCurrentTime

  (registration, application) <- runDB $ do
    registration <- fmap join . for muid $ fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy . flip UniqueParticipant cid
    application <- fmap (listToMaybe =<<) . for muid $ \uid -> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Nothing] []
    return (registration, application)
  let btn | courseApplicationsRequired
          , is _Just application
          = BtnCourseRetractApplication
          | is _Just registration
          = BtnCourseDeregister
          | courseApplicationsRequired
          = BtnCourseApply
          | otherwise
          = BtnCourseRegister
      isRegistered = btn `elem` [BtnCourseRetractApplication, BtnCourseDeregister]
  return . (, btn) . wFormToAForm $ do
    MsgRenderer mr <- getMsgRenderer

    secretRes <- if
      | Just secret <- courseRegisterSecret
      , not isRegistered
        -> let guardSecret (FormSuccess secret')
                 | secret == secret' = return $ FormSuccess ()
                 | otherwise         = formFailure [MsgCourseSecretWrong]
               guardSecret  FormMissing       = return   FormMissing
               guardSecret (FormFailure errs) = return $ FormFailure errs
            in guardSecret =<< wreq textField (fslpI MsgCourseSecret $ mr MsgCourseSecret) Nothing
      | otherwise
        -> return $ FormSuccess ()

    appTextRes <- let fs | courseApplicationsRequired
                         , is _Just courseApplicationsInstructions
                         = fslI MsgCourseApplicationText & setTooltip MsgCourseApplicationFollowInstructions
                         | courseApplicationsRequired
                         = fslI MsgCourseApplicationText
                         | is _Just courseApplicationsInstructions
                         = fslI MsgCourseRegistrationText & setTooltip MsgCourseRegistrationFollowInstructions
                         | otherwise
                         = fslI MsgCourseRegistrationText
                      textField' = convertField unTextarea Textarea textareaField
                   in if
      | not courseApplicationsText
        -> return $ FormSuccess Nothing
      | is _Just muid
      , isRegistered
        -> wforced (convertField Just (fromMaybe Text.empty) textField') fs (application >>= courseApplicationText . entityVal)
      | otherwise
        -> fmap (assertM (not . Text.null) . fmap Text.strip) <$> wopt textField' fs (Just $ application >>= courseApplicationText . entityVal)

    appFilesInfo <- for application $ \(Entity appId _) -> liftHandler . runDB $ do
      hasFiles <- exists [ CourseApplicationFileApplication ==. appId ]
      appCID <- encrypt appId
      appFilesLink <- toTextUrl $ CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR
      return (hasFiles, appFilesLink)
    let hasFiles = maybe False (view _1) appFilesInfo
        filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired

    when (isn't _NoUpload courseApplicationsFiles || hasFiles) $
      let filesLinkField = Field{..}
            where
              fieldParse _ _ = return $ Right Nothing
              fieldEnctype = mempty
              fieldView theId _ attrs _ _ =
                [whamlet|
                  $newline never
                    $case appFilesInfo
                      $of Just (True, appFilesLink)
                        <a ##{theId} *{attrs} href=#{appFilesLink}>
                          _{filesMsg}
                      $of _
                        <span ##{theId} *{attrs}>
                          _{MsgCourseApplicationNoFiles}
                |]
       in void $ wforced filesLinkField (fslI filesMsg) Nothing

    when (hasFiles && isn't _NoUpload courseApplicationsFiles) $
      wformMessage <=< messageIconI Info IconFileUpload $ bool MsgCourseRegistrationFilesNeedReupload MsgCourseApplicationFilesNeedReupload courseApplicationsRequired

    appFilesRes <- let mkFs | courseApplicationsRequired = bool MsgCourseApplicationFile MsgCourseApplicationArchive
                            | otherwise                  = bool MsgCourseRegistrationFile MsgCourseRegistrationArchive
                    in if
      | isRegistered
        -> return $ FormSuccess Nothing
      | otherwise
        -> aFormToWForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles

    mayViewCourseAfterDeregistration <- liftHandler . runDB $ E.selectExists . E.from $ \course -> E.where_ $
      course E.^. CourseId E.==. E.val cid
      E.&&. ( isSchoolAdminLike muid ata (course E.^. CourseSchool)
        E.||. mayEditCourse muid ata course
        E.||. courseIsVisible now course Nothing
        E.||. isCourseLecturer muid ata (course E.^. CourseId)
        E.||. isCourseTutor muid ata (course E.^. CourseId)
        E.||. isCourseSheetCorrector muid ata (course E.^. CourseId)
        E.||. isCourseExamCorrector muid ata (course E.^. CourseId)
        )

    mayReRegister <- liftHandler . runDB . courseMayReRegister $ Entity cid Course{..}

    when (is _Just $ registration >>= courseParticipantAllocated . entityVal) $
      wformMessage =<< messageIconI Warning IconExamRegisterFalse MsgCourseDeregistrationAllocationLog
    when (is _Just (registration >>= courseParticipantAllocated . entityVal) && courseDeregisterNoShow) $
      wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationNoShow
    when (isRegistered && not mayViewCourseAfterDeregistration) $
      wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationFromInvisibleCourse
    unless mayReRegister $
      wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationNoReRegistration

    return $ CourseRegisterForm
      <$  secretRes
      <*> appTextRes
      <*> appFilesRes

courseMayReRegister :: Entity Course -> DB Bool
courseMayReRegister (Entity cid Course{..}) = do
  registrations <- count [ CourseParticipantState ==. CourseParticipantActive, CourseParticipantCourse ==. cid ]
  let capacity = maybe True (>= registrations) courseCapacity
  
  wouldHaveWriteAccessTo [(AuthCapacity, capacity), (AuthCourseRegistered, False)] $ CourseR courseTerm courseSchool courseShorthand CRegisterR


-- | Workaround for klicking register button without being logged in.
-- After log in, the user sees a "get request not supported" error.
getCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCRegisterR tid ssh csh = do
  muid <- maybeAuthId
  case muid of
    Nothing -> addMessageI Info MsgLoginNecessary
    (Just uid) -> runDB $ do
      cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
      registration <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
      when (isNothing registration) $ addMessageI Warning MsgRegisterRetry
  redirect $ CourseR tid ssh csh CShowR

postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
postCRegisterR tid ssh csh = do
  uid <- requireAuthId
  course@(Entity cid Course{..}) <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
  (courseRegisterForm', courseRegisterButton) <- courseRegisterForm course
  ((regResult,_), _) <- runFormPost $ renderAForm FormStandard courseRegisterForm'
  formResult regResult $ \CourseRegisterForm{..} -> do
    cTime <- liftIO getCurrentTime
    let
      doApplication = courseApplicationsRequired || is _Just (void crfApplicationText <|> void crfApplicationFiles)
      mkApplication
        | doApplication
        = void <$> do
            appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] []
            appRes <- case appIds of
              [] -> insertUnique $ CourseApplication cid uid crfApplicationText False Nothing Nothing Nothing Nothing cTime Nothing
              (prevId:ps) -> do
                forM_ ps $ \appId -> do
                  deleteApplicationFiles appId
                  delete appId
                  audit $ TransactionCourseApplicationDeleted cid uid appId

                deleteApplicationFiles prevId
                update prevId [ CourseApplicationText =. crfApplicationText, CourseApplicationTime =. cTime ]

                return $ Just prevId

            whenIsJust appRes $
              audit . TransactionCourseApplicationEdit cid uid
            whenIsJust ((,) <$> appRes <*> crfApplicationFiles) $ \(appId, fSource) -> do
              runConduit $ transPipe liftHandler fSource .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId))
            return appRes
        | otherwise
        = return $ Just ()
      mkRegistration = do
        audit $ TransactionCourseParticipantEdit cid uid
        memcachedByInvalidate (AuthCacheCourseRegisteredList courseTerm courseSchool courseShorthand) (Proxy @(Set UserId))
        entityKey <$> upsert
          (CourseParticipant cid uid cTime Nothing CourseParticipantActive)
          [ CourseParticipantRegistration =. cTime
          , CourseParticipantAllocated =. Nothing
          , CourseParticipantState =. CourseParticipantActive
          ]

    case courseRegisterButton of
      BtnCourseRegister -> runDB . bool id setSerializable doApplication $ do
        regOk <- (\app reg -> (, reg) <$> app) <$> mkApplication <*> mkRegistration
        case regOk of
          Nothing -> transactionUndo
          Just _  -> addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
      BtnCourseDeregister -> runDB . setSerializable $ do
        part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
        forM_ part $ \(Entity _partId CourseParticipant{..}) -> do
          deregisterParticipant uid course

          when (is _Just courseParticipantAllocated) $ do
            updateBy (UniqueParticipant uid cid) [ CourseParticipantState =. CourseParticipantInactive courseDeregisterNoShow ]

            now <- liftIO getCurrentTime
            insert_ $ AllocationDeregister courseParticipantUser (Just courseParticipantCourse) now Nothing
            let recordNoShow eId = do
                  didRecord <- is _Just <$> insertUnique ExamResult
                    { examResultExam = eId
                    , examResultUser = uid
                    , examResultResult = ExamNoShow
                    , examResultLastChanged = now
                    }
                  when didRecord $
                    audit $ TransactionExamResultEdit eId uid
            when courseDeregisterNoShow . runConduit $ selectKeys [ ExamCourse ==. cid ] [] .| C.mapM_ recordNoShow

        addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk
      BtnCourseApply -> runDB . setSerializable $ do
        regOk <- mkApplication
        case regOk of
          Nothing -> transactionUndo
          Just _  -> addMessageIconI Success IconApplyTrue MsgCourseApplyOk
      BtnCourseRetractApplication -> runDB $ do
        deleteApplications uid cid
        addMessageIconI Info IconApplyFalse MsgCourseRetractApplyOk
  muid <- maybeAuthId
  ata <- getSessionActiveAuthTags
  now <- liftIO getCurrentTime
  courseVisible <- runDB . E.selectExists . E.from $ \c -> E.where_ $
    c E.^. CourseId E.==. E.val cid
    E.&&. mayViewCourse muid ata now c Nothing
  redirect $ bool NewsR (CourseR tid ssh csh CShowR) courseVisible

deleteApplications :: UserId -> CourseId -> DB ()
deleteApplications uid cid = do
  appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] []
  forM_ appIds $ \appId -> do
    deleteApplicationFiles appId
    delete appId
    audit $ TransactionCourseApplicationDeleted cid uid appId

deleteApplicationFiles :: CourseApplicationId -> DB ()
deleteApplicationFiles appId = deleteWhere [ CourseApplicationFileApplication ==. appId ]

deregisterParticipant :: UserId -> Entity Course -> DB ()
deregisterParticipant uid (Entity cid Course{..}) = do
  part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
  forM_ part $ \(Entity partId CourseParticipant{}) -> do
    update partId [CourseParticipantState =. CourseParticipantInactive False]
    audit $ TransactionCourseParticipantDeleted cid uid
    memcachedByInvalidate (AuthCacheCourseRegisteredList courseTerm courseSchool courseShorthand) (Proxy @(Set UserId))

  examRegistrations <- E.select . E.from $ \(examRegistration `E.InnerJoin` exam) -> do
    E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
    E.where_ $ exam E.^. ExamCourse E.==. E.val cid
         E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid
    return examRegistration
  forM_ examRegistrations $ \(Entity _ ExamRegistration{..}) -> do
    deregisterExamUsers examRegistrationExam $ pure examRegistrationUser

  E.delete . E.from $ \tutorialParticipant -> do
    let tutorialCourse = E.subSelectForeign tutorialParticipant TutorialParticipantTutorial (E.^. TutorialCourse)

    E.where_ $ tutorialCourse E.==. E.val cid
         E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid
