fradrive/src/Handler/Allocation/AddUser.hs

module Handler.Allocation.AddUser
  ( getAAddUserR, postAAddUserR
  ) where

import Import
import Handler.Allocation.Application

import Handler.Utils

import qualified Data.Map as Map

import qualified Data.Conduit.Combinators as C

import qualified Database.Esqueleto as E


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

getAAddUserR, postAAddUserR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
getAAddUserR = postAAddUserR
postAAddUserR tid ssh ash = do
  (Entity _ Allocation{..}, (addUserAct, addUserForm, addUserEnctype)) <- runDB $ do
    alloc@(Entity aId _) <- getBy404 $ TermSchoolAllocationShort tid ssh ash
    allocCourses <- 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
    ((addUserRes, addUserForm), addUserEnctype) <- liftHandler . runFormPost . renderAForm FormStandard $ AllocationAddUserForm
      <$> areq (checkMap (first $ const MsgAllocationAddUserUserNotFound) Right $ userField False Nothing) (fslpI MsgAllocationAddUserUser (mr MsgAllocationAddUserUserPlaceholder)) Nothing
      <*> areq (posIntFieldI MsgAllocationAddUserTotalCoursesLessThanOne) (fslI MsgAllocationAddUserTotalCourses) (Just 1)
      <*> optionalActionA (allocationPriorityForm (fslI MsgAllocationAddUserPriority) Nothing) (fslI MsgAllocationAddUserSetPriority) (Just True)
      <*> allocationApplicationsForm aId (Map.fromList [ (cId, (course, allocationCourse, hasTemplate)) | (Entity cId course, E.Value hasTemplate, Entity _ allocationCourse) <- allocCourses ]) (fslI MsgAllocationAddUserApplications) False

    addUserAct <- formResultMaybe addUserRes $ \AllocationAddUserForm{..} -> Just <$> do
      now <- liftIO getCurrentTime
      
      didInsert <- is _Just <$> insertUnique AllocationUser
        { allocationUserAllocation = aId
        , allocationUserUser = aauUser
        , allocationUserTotalCourses = aauTotalCourses
        , allocationUserPriority = aauPriority
        }

      if
        | didInsert -> do
            oldApps <- selectList [CourseApplicationUser ==. aauUser, CourseApplicationAllocation ==. Just aId] []
            forM_ oldApps $ \(Entity appId CourseApplication{..}) -> do
              delete appId
              unless (courseApplicationCourse `Map.member` aauApplications) $ 
                audit $ TransactionCourseApplicationDeleted courseApplicationCourse courseApplicationUser appId

            iforM_ aauApplications $ \cId ApplicationForm{..} -> maybeT (return ()) $ do
              prio <- hoistMaybe afPriority
              let rated = afRatingVeto || is _Just afRatingPoints
              appId <- lift $ insert CourseApplication
                { courseApplicationCourse = cId
                , courseApplicationUser = aauUser
                , courseApplicationText = afText
                , courseApplicationRatingVeto = afRatingVeto
                , courseApplicationRatingPoints = afRatingPoints
                , courseApplicationRatingComment = afRatingComment
                , courseApplicationAllocation = Just aId
                , courseApplicationAllocationPriority = Just prio
                , courseApplicationTime = now
                , courseApplicationRatingTime = guardOn rated now
                }
              lift . runConduit $ transPipe liftHandler (sequence_ afFiles) .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId))
              lift . audit $ TransactionCourseApplicationEdit cId aauUser appId

            return $ do
              addMessageI Success MsgAllocationAddUserUserAdded
              redirect $ AllocationR tid ssh ash AAddUserR
        | otherwise -> return $ addMessageI Error MsgAllocationAddUserUserExists
  
    return (alloc, (addUserAct, addUserForm, addUserEnctype))

  sequence_ addUserAct

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

  siteLayoutMsg title $ do
    setTitleI shortTitle
    wrapForm addUserForm FormSettings
      { formMethod = POST
      , formAction = Just . SomeRoute $ AllocationR tid ssh ash AAddUserR
      , formEncoding = addUserEnctype
      , formAttrs = []
      , formSubmit = FormSubmit
      , formAnchor = Nothing :: Maybe Text
      }

allocationApplicationsForm :: AllocationId
                           -> Map CourseId (Course, AllocationCourse, Bool)
                           -> FieldSettings UniWorX
                           -> Bool
                           -> AForm Handler (Map CourseId ApplicationForm)
allocationApplicationsForm aId 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
    over _2 (course, allocCourse, mApplicationTemplate, ) <$> applicationForm (Just aId) cId Nothing 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, 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}
                $if is _Just mApplicationTemplate || is _Just courseApplicationsInstructions
                  <div .allocation-course__instructions-label .allocation__label>
                    _{MsgCourseApplicationInstructionsApplication}
                  <div .allocation-course__instructions>
                    $maybe aInst <- courseApplicationsInstructions
                      <p>
                        #{aInst}
                    $maybe templateUrl <- mApplicationTemplate
                      <p>
                        <a href=#{templateUrl}>
                          #{iconRegisterTemplate} _{MsgCourseApplicationTemplateApplication}
                <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{..})