module Handler.Allocation.UserForm
  ( AllocationUserForm(..)
  , allocationUserForm
  , CourseParticipantForm(..)
  , _CourseParticipantFormNotAllocated, _CourseParticipantFormDeregistered, _CourseParticipantFormRegistered, _cpfDeregisterReason, _cpfEverRegistered
  , CourseParticipantForm'
  , courseParticipantForm
  ) where

import Import
import Handler.Allocation.Application

import Handler.Utils

import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.PostgreSQL as E
import qualified Data.Map.Strict as Map

import Text.Blaze (toMarkup)


data AllocationUserForm = AllocationUserForm
  { aauUser :: UserId
  , aauTotalCourses :: Word64
  , aauPriority :: Maybe AllocationPriority
  , aauApplications :: Map CourseId ApplicationForm
  }


allocationUserForm :: forall m backend.
                      ( MonadHandler m, HandlerSite m ~ UniWorX
                      , E.SqlBackendCanRead backend, IsSqlBackend backend
                      )
                   => AllocationId
                   -> Maybe AllocationUserForm
                   -> AForm (ReaderT backend m) AllocationUserForm
allocationUserForm aId mTemplate = wFormToAForm $ do
  allocCourses <- lift . lift . E.select . E.from $ \(course `E.InnerJoin` allocationCourse) -> do
    E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
    E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId
    return ( course
           , E.exists . E.from $ \courseAppInstructionFile ->
               E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. course E.^. CourseId
           , allocationCourse
           )
  
  MsgRenderer mr <- getMsgRenderer
  
  userRes <- case aauUser <$> mTemplate of
    Just u -> do
      User{..} <- lift . lift $ get404 u
      fvId <- newIdent
      lift . tell $ pure FieldView
        { fvLabel = toMarkup $ mr MsgAllocationAddUserUser
        , fvTooltip = Nothing
        , fvId
        , fvInput = nameWidget userDisplayName userSurname
        , fvErrors = Nothing
        , fvRequired = False
        }
      return $ FormSuccess u
    Nothing -> wreq (checkMap (first $ const MsgAllocationAddUserUserNotFound) Right $ userField False Nothing) (fslpI MsgAllocationAddUserUser (mr MsgAllocationAddUserUserPlaceholder)) Nothing

  totalCoursesRes <- wreq (posIntFieldI MsgAllocationAddUserTotalCoursesLessThanOne) (fslI MsgAllocationAddUserTotalCourses) ((aauTotalCourses <$> mTemplate) <|> Just 1)

  priorityRes <- hoist (hoist liftHandler) $ optionalActionW (allocationPriorityForm (fslI MsgAllocationAddUserPriority) $ aauPriority =<< mTemplate) (fslI MsgAllocationAddUserSetPriority) ((is _Just . aauPriority <$> mTemplate) <|> Just True)

  applicationsRes <- aFormToWForm $ allocationApplicationsForm aId (aauUser <$> mTemplate) (Map.fromList [ (cId, (course, allocationCourse, hasTemplate)) | (Entity cId course, E.Value hasTemplate, Entity _ allocationCourse) <- allocCourses ]) (fslI MsgAllocationAddUserApplications) False

  return $ AllocationUserForm
    <$> userRes
    <*> totalCoursesRes
    <*> priorityRes
    <*> applicationsRes


allocationApplicationsForm :: forall m backend.
                              ( MonadHandler m, HandlerSite m ~ UniWorX
                              , E.SqlBackendCanRead backend
                              )
                           => AllocationId
                           -> Maybe UserId
                           -> Map CourseId (Course, AllocationCourse, Bool)
                           -> FieldSettings UniWorX
                           -> Bool
                           -> AForm (ReaderT backend m) (Map CourseId ApplicationForm)
allocationApplicationsForm aId muid courses FieldSettings{..} fvRequired  = formToAForm $ do
  now <- liftIO getCurrentTime
  
  let afmApplicant = True
      afmApplicantEdit = True
      afmLecturer = True

  appsRes' <- iforM courses $ \cId (course, allocCourse, hasApplicationTemplate) -> do
    mApplicationTemplate <- runMaybeT $ do
      guard hasApplicationTemplate
      let Course{..} = course
      toTextUrl $ CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR
    counts <- lift . fmap (maybe (Nothing, 0) $ bimap (assertM' (> 0) . E.unValue) E.unValue) . E.selectMaybe . E.from $ \courseApplication -> do
      E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cId
           E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.justVal aId
      let hasRating = E.isJust (courseApplication E.^. CourseApplicationRatingPoints)
                E.||. E.isJust (courseApplication E.^. CourseApplicationRatingComment)
                E.||. courseApplication E.^. CourseApplicationRatingVeto
      return ( E.count (courseApplication E.^. CourseApplicationId) `E.filterWhere` hasRating
             , E.count (courseApplication E.^. CourseApplicationId) `E.filterWhere` (courseApplication E.^. CourseApplicationRatingVeto)
             )
    hoist liftHandler $ over _2 (course, allocCourse, mApplicationTemplate, counts, ) <$> applicationForm (Just aId) cId muid ApplicationFormMode{..} Nothing
  let appsRes = sequenceA $ view _1 <$> appsRes'
      appsViews = view _2 <$> appsRes'
  
  let fvInput =
        [whamlet|
          $newline never
          <div .allocation__courses>
            $forall (Course{courseTerm, courseSchool, courseShorthand, courseName, courseApplicationsInstructions}, AllocationCourse{allocationCourseAcceptSubstitutes}, mApplicationTemplate, (mRatings, vetos), ApplicationFormView{afvPriority, afvForm}) <- Map.elems appsViews
              <div .allocation-course>
                <div .allocation-course__priority-label .allocation__label>
                  _{MsgAllocationPriority}
                <div .allocation-course__priority>
                  $maybe prioView <- afvPriority
                    ^{fvWidget prioView}
                <a .allocation-course__name href=@{CourseR courseTerm courseSchool courseShorthand CShowR} target="_blank">
                  #{courseName}
                <div .allocation-course__admin-info>
                  <p>
                    $maybe deadline <- allocationCourseAcceptSubstitutes
                      _{MsgCourseAllocationCourseAcceptsSubstitutesUntil}: #
                      ^{formatTimeW SelFormatDateTime deadline}
                    $nothing
                      _{MsgCourseAllocationCourseAcceptsSubstitutesNever}
                    $if allocationCourseAcceptSubstitutes >= Just now
                      \ ^{iconOK}
                  $maybe ratings <- mRatings
                    ^{notification NotificationBroad =<< messageI Warning (MsgAllocationCourseHasRatings ratings vetos)}
                $if is _Just mApplicationTemplate || is _Just courseApplicationsInstructions
                  <div .allocation-course__instructions-label .allocation__label>
                    _{MsgCourseAllocationApplicationInstructionsApplication}
                  <div .allocation-course__instructions>
                    $maybe aInst <- courseApplicationsInstructions
                      <p>
                        #{aInst}
                    $maybe templateUrl <- mApplicationTemplate
                      <p>
                        <a href=#{templateUrl}>
                          #{iconRegisterTemplate} _{MsgCourseAllocationApplicationTemplateApplication}
                <div .allocation-course__application-label .interactive-fieldset__target .allocation__label uw-interactive-fieldset data-conditional-input=#{maybe "" fvId afvPriority} data-conditional-value="" data-conditional-negated>
                  _{MsgCourseApplication}
                <div .allocation-course__application .interactive-fieldset__target uw-interactive-fieldset data-conditional-input=#{maybe "" fvId afvPriority} data-conditional-value="" data-conditional-negated>
                  ^{renderFieldViews FormStandard afvForm}
        |]
  MsgRenderer mr <- getMsgRenderer
  let fvLabel = toHtml $ mr fsLabel
      fvTooltip = toHtml . mr <$> fsTooltip
      fvErrors = case appsRes of
        FormFailure errs -> Just
          [shamlet|
            $newline never
            <ul>
              $forall err <- errs
                <li>#{err}
          |]
        _other -> Nothing
  fvId <- maybe newIdent return fsId
  
  return (appsRes, pure FieldView{..})


data CourseParticipantForm
  = CourseParticipantFormNotAllocated -- ^ User is registered but not through allocation; no control
  | CourseParticipantFormDeregistered -- ^ User is not currently registered
    { cpfDeregisterReason :: Maybe Text -- ^ `Just` if user was deregistered "self-inflicted", reason is required
    , cpfEverRegistered :: Bool
    }
  | CourseParticipantFormRegistered -- ^ User is currently registered
  deriving (Eq, Ord, Read, Show, Generic, Typeable)

type CourseParticipantForm' = Map CourseId CourseParticipantForm

makePrisms ''CourseParticipantForm
makeLenses_ ''CourseParticipantForm

courseParticipantForm :: forall m.
                         ( MonadHandler m, HandlerSite m ~ UniWorX )
                      => Map CourseId ((TermId, SchoolId, CourseShorthand), CourseName, CourseParticipantForm)
                      -> (Html -> MForm m (FormResult CourseParticipantForm', Widget))
courseParticipantForm courses csrf = do
  lines' <- iforM courses $ \_cId ((tid, ssh, csh), cname, prevSt)
    -> let toLine fCell = $(widgetFile "allocation/user-course-participant-form/line")
        in over _2 toLine <$> case prevSt of
             CourseParticipantFormNotAllocated -> do
               (_, isRegView) <- mforced checkBoxField def True
               return ( FormSuccess CourseParticipantFormNotAllocated
                      , $(widgetFile "allocation/user-course-participant-form/not-allocated")
                      )
             _other -> do
               let deregReason = prevSt ^? _cpfDeregisterReason . _Just
                   isRegPrev = is _CourseParticipantFormRegistered prevSt
                   everRegistered = fromMaybe True $ prevSt ^? _cpfEverRegistered
               (isRegRes, isRegView) <- mpopt checkBoxField def $ Just isRegPrev
               let selfInflictedFS = def
                     & addAttr "uw-interactive-fieldset" ""
                     & addAttr "data-conditional-input" (fvId isRegView)
                     & addAttr "data-conditional-negated" ""
               (isSelfInflictedRes, isSelfInflictedView) <- if
                 | everRegistered -> over _2 Just <$> mopt (textField & cfStrip) selfInflictedFS (Just deregReason)
                 | otherwise -> return (FormSuccess Nothing, Nothing)
               return ( case isRegRes of
                          FormMissing -> FormMissing
                          FormFailure es1 -> FormFailure $ es1 <> view _FormFailure isSelfInflictedRes
                          FormSuccess True
                            | FormFailure es2 <- isSelfInflictedRes
                              -> FormFailure es2
                            | otherwise 
                               -> FormSuccess CourseParticipantFormRegistered
                          FormSuccess False
                            -> CourseParticipantFormDeregistered <$> isSelfInflictedRes <*> pure everRegistered
                      , $(widgetFile "allocation/user-course-participant-form/cell")
                      )
  let linesWidget = Map.intersectionWith (,) courses lines'
        & Map.elems
        & sortOn (view $ _1 . _1)
        & view (folded . _2 . _2)
  return ( forM lines' $ view _1
         , $(widgetFile "allocation/user-course-participant-form/layout")
         )