module Handler.Allocation.Show
  ( getAShowR, postAShowR
  ) where

import Import

import Utils.Course

import Handler.Utils
import Handler.Utils.Allocation (allocationNotifyNewCourses)

import Handler.Allocation.Register
import Handler.Allocation.Application

import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E


data NotifyNewCourseButton
  = BtnNotifyNewCourseForceOn
  | BtnNotifyNewCourseForceOff
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
  deriving anyclass (Universe, Finite)
embedRenderMessage ''UniWorX ''NotifyNewCourseButton id
nullaryPathPiece ''NotifyNewCourseButton $ camelToPathPiece' 2

instance Button UniWorX NotifyNewCourseButton where
  btnLabel BtnNotifyNewCourseForceOn
    = [whamlet|
        $newline never
        #{iconNotification} \
        _{BtnNotifyNewCourseForceOn}
      |]
  btnLabel BtnNotifyNewCourseForceOff
    = [whamlet|
        $newline never
        #{iconNoNotification} \
        _{BtnNotifyNewCourseForceOff}
      |]

  btnClasses _ = [BCIsButton]


getAShowR, postAShowR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
getAShowR = postAShowR
postAShowR tid ssh ash = do
  muid <- maybeAuthId
  now  <- liftIO getCurrentTime
  ata  <- getSessionActiveAuthTags

  let
    resultCourse :: _ => Lens' a (Entity Course)
    resultCourse = _1
    resultCourseApplication :: _ => Traversal' a (Entity CourseApplication)
    resultCourseApplication = _2 . _Just
    resultHasTemplate :: _ => Lens' a Bool
    resultHasTemplate = _3 . _Value
    resultIsRegistered :: _ => Lens' a Bool
    resultIsRegistered = _4 . _Value
    resultCourseVisible :: _ => Lens' a Bool
    resultCourseVisible = _5 . _Value
    resultAllocationCourse :: _ => Lens' a AllocationCourse
    resultAllocationCourse = _6 . _entityVal
    resultParticipantCount :: _ => Lens' a Int
    resultParticipantCount = _7 . _Value
    resultRatingsCount :: _ => Getter a (Maybe Word64)
    resultRatingsCount = _8 . _1 . _Value . to (assertM' (> 0))
    resultVetosCount :: _ => Lens' a Word64
    resultVetosCount = _8 . _2 . _Value

  (Entity aId Allocation{..}, School{..}, isAnyLecturer, isAdmin, courses, registration, wouldNotifyNewCourse) <- runDB $ do
    alloc@(Entity aId Allocation{allocationSchool}) <- getBy404 $ TermSchoolAllocationShort tid ssh ash
    school <- getJust allocationSchool

    courses <- E.select . E.from $ \((allocationCourse `E.InnerJoin` course) `E.LeftOuterJoin` courseApplication `E.LeftOuterJoin` registration) -> do
      E.on $ registration E.?. CourseParticipantCourse E.==. E.just (course E.^. CourseId)
        E.&&. registration E.?. CourseParticipantUser E.==. E.val muid
        E.&&. registration E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive)
      E.on $ courseApplication E.?. CourseApplicationCourse E.==. E.just (course E.^. CourseId)
        E.&&. courseApplication E.?. CourseApplicationUser E.==. E.val muid
        E.&&. courseApplication E.?. CourseApplicationAllocation E.==. E.just (E.just $ E.val aId)
      E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
      E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId
        E.&&. ( E.isJust (courseApplication E.?. CourseApplicationId)
          E.||. mayViewCourse muid ata now course (E.justVal aId)
        )
      E.orderBy [E.asc $ course E.^. CourseName]
      let hasTemplate = E.exists . E.from $ \courseAppInstructionFile ->
            E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. course E.^. CourseId
          participantCount = E.subSelectCount . E.from $ \courseParticipant ->
            E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
                 E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
          ratingsCount = E.subSelectCount . E.from $ \courseApplication' -> do
            E.where_ $ courseApplication' E.^. CourseApplicationCourse E.==. course E.^. CourseId
                 E.&&. courseApplication' E.^. CourseApplicationAllocation E.==. E.justVal aId
                 E.&&. (       E.isJust (courseApplication' E.^. CourseApplicationRatingPoints)
                         E.||. E.isJust (courseApplication' E.^. CourseApplicationRatingComment)
                         E.||. courseApplication' E.^. CourseApplicationRatingVeto
                       )
          vetosCount = E.subSelectCount . E.from $ \courseApplication' -> do
            E.where_ $ courseApplication' E.^. CourseApplicationCourse E.==. course E.^. CourseId
                 E.&&. courseApplication' E.^. CourseApplicationAllocation E.==. E.justVal aId
                 E.&&. courseApplication' E.^. CourseApplicationRatingVeto
      return ( course
             , courseApplication
             , hasTemplate
             , E.not_ . E.isNothing $ registration E.?. CourseParticipantId
             , courseIsVisible now course $ E.justVal aId
             , allocationCourse
             , participantCount
             , (ratingsCount, vetosCount)
             )

    registration <- fmap join . for muid $ getBy . UniqueAllocationUser aId

    isAnyLecturer <- hasWriteAccessTo CourseNewR
    isAdmin <- hasReadAccessTo $ AllocationR tid ssh ash AUsersR

    wouldNotifyNewCourse <- fmap (maybe False E.unValue . join) . for muid $ E.selectMaybe . pure . allocationNotifyNewCourses (E.val aId) . E.val

    return (alloc, school, isAnyLecturer, isAdmin, nubOrdOn (view $ resultCourse . _entityKey) courses, registration, wouldNotifyNewCourse)

  let nextSubstitutesDeadline = minimumOf (folded . resultAllocationCourse . _allocationCourseAcceptSubstitutes . _Just . filtered (>= now)) courses
      freeCapacity = fmap getSum . getAp . flip foldMap courses $ \cEntry -> Ap . fmap (Sum . max 0) $ subtract (cEntry ^. resultParticipantCount) <$> preview (resultCourse . _entityVal . _courseCapacity . _Just) cEntry

  MsgRenderer mr <- getMsgRenderer
  let title = MsgAllocationTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationName
      shortTitle = MsgAllocationShortTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationShorthand

  -- staffInformation <- anyM courses $ \(view $ resultCourse . _entityVal -> Course{..}) ->
  --   hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CApplicationsR
  mayRegister <- hasWriteAccessTo $ AllocationR tid ssh ash ARegisterR
  (registerForm, registerEnctype) <- generateFormPost . identifyForm FIDAllocationRegister . renderAForm FormStandard . allocationRegisterForm $ allocationUserToForm . entityVal <$> registration
  let
    registerBtn = bool BtnAllocationRegister BtnAllocationRegistrationEdit $ is _Just registration
    registerForm' = wrapForm' registerBtn registerForm FormSettings
      { formMethod = POST
      , formAction = Just . SomeRoute $ AllocationR tid ssh ash ARegisterR
      , formEncoding = registerEnctype
      , formAttrs = []
      , formSubmit = FormSubmit
      , formAnchor = Nothing :: Maybe Text
      }

  ((notificationResult, notificationForm), notificationEnctype) <- runFormPost . identifyForm FIDAllocationNotification . buttonForm' $ if
    | wouldNotifyNewCourse
      -> [BtnNotifyNewCourseForceOff]
    | otherwise
      -> [BtnNotifyNewCourseForceOn]
  let
    allocationNotificationIdent = "allocation-notification" :: Text
    notificationForm' = wrapForm notificationForm FormSettings
      { formMethod = POST
      , formAction = Just . SomeRoute $ AllocationR tid ssh ash AShowR
      , formEncoding = notificationEnctype
      , formAttrs = []
      , formSubmit = FormNoSubmit
      , formAnchor = Just allocationNotificationIdent
      }

  whenIsJust muid $ \uid -> formResult notificationResult $ \notificationBtn -> do
    let allocationNotificationSettingIsOptOut = case notificationBtn of
          BtnNotifyNewCourseForceOn  -> False
          BtnNotifyNewCourseForceOff -> True
    runDB . void $ upsertBy (UniqueAllocationNotificationSetting uid aId) AllocationNotificationSetting
      { allocationNotificationSettingUser = uid
      , allocationNotificationSettingAllocation = aId
      , allocationNotificationSettingIsOptOut
      }
      [ AllocationNotificationSettingIsOptOut =. allocationNotificationSettingIsOptOut ]
    addMessageI Success $ bool MsgAllocationNotificationNewCourseSuccessForceOn MsgAllocationNotificationNewCourseSuccessForceOff allocationNotificationSettingIsOptOut
    redirect $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: allocationNotificationIdent

  siteLayoutMsg title $ do
    setTitleI shortTitle

    let courseWidgets = flip map courses $ \cEntry -> do
          let Entity cid Course{..}  = cEntry ^. resultCourse
              hasApplicationTemplate = cEntry ^. resultHasTemplate
              mApp                   = cEntry ^? resultCourseApplication
              isRegistered           = cEntry ^. resultIsRegistered
              courseVisible          = cEntry ^. resultCourseVisible
              AllocationCourse{..}   = cEntry ^. resultAllocationCourse
              partCount              = cEntry ^. resultParticipantCount
              mRatings               = cEntry ^. resultRatingsCount
              vetos                  = cEntry ^. resultVetosCount
          cID <- encrypt cid :: WidgetFor UniWorX CryptoUUIDCourse
          mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID
          mayEdit <- hasWriteAccessTo $ CourseR tid ssh courseShorthand CEditR
          isLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
          mApplyFormView <- liftHandler . for muid $ \uid -> generateFormPost $ applicationForm (Just aId) cid (Just uid) (ApplicationFormMode True mayApply isLecturer) . Just
          tRoute <- case mApp of
            Nothing -> return . AllocationR tid ssh ash $ AApplyR cID
            Just (Entity appId _) -> CApplicationR courseTerm courseSchool courseShorthand <$> encrypt appId <*> pure CAEditR
          mApplicationTemplate <- runMaybeT $ do
            guard hasApplicationTemplate
            toTextUrl $ CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR

          let mApplyFormView' = view _1 <$> mApplyFormView
              overrideVisible = not mayApply && is _Just mApp
          case mApplyFormView of
            Just (_, appFormEnctype)
              -> wrapForm $(widgetFile "allocation/show/course") FormSettings
                 { formMethod = POST
                 , formAction = Just $ SomeRoute tRoute
                 , formEncoding = appFormEnctype
                 , formAttrs = [ ("class", "allocation-course")
                               ]
                 , formSubmit = FormNoSubmit
                 , formAnchor = Just cID
                 }
            Nothing
              -> let wdgt = $(widgetFile "allocation/show/course")
                  in [whamlet|
                       <div .allocation-course ##{toPathPiece cID}>
                         ^{wdgt}
                     |]
    let daysToRegistrationStart = assertM (>0) $ (`diffUTCTime` now) <$> allocationRegisterFrom
        allocationInfoModal     = modal [whamlet|_{MsgHeadingAllocationInfo}|] $ Left $ SomeRoute InfoAllocationR
        numCourses = length courses
        numAppliedCourses = lengthOf (folded . _2 . _Just) courses
    $(widgetFile "allocation/show")