fradrive/src/Handler/Allocation/EditUser.hs

module Handler.Allocation.EditUser
  ( getAEditUserR, postAEditUserR
  , getADelUserR, postADelUserR
  ) where

import Import
import Handler.Allocation.Application
import Handler.Allocation.UserForm

import Handler.Utils

import qualified Data.Map.Strict as Map
import qualified Data.Set as Set

import qualified Data.Conduit.Combinators as C

import Handler.Utils.Delete

import qualified Database.Esqueleto as E


getAEditUserR, postAEditUserR :: TermId -> SchoolId -> AllocationShorthand -> CryptoUUIDUser -> Handler Html
getAEditUserR = postAEditUserR
postAEditUserR tid ssh ash cID = do
  (Entity _ Allocation{..}, User{..}, (editUserAct, editUserForm, editUserEnctype)) <- runDB $ do
    uid <- decrypt cID
    user <- get404 uid
    alloc@(Entity aId _) <- getBy404 $ TermSchoolAllocationShort tid ssh ash
    Entity auId AllocationUser{..} <- getBy404 $ UniqueAllocationUser aId uid

    ((editUserRes, editUserForm), editUserEnctype) <- runFormPost . renderAForm FormStandard $ 
      allocationUserForm aId $ Just AllocationUserForm
        { aauUser = uid
        , aauTotalCourses = allocationUserTotalCourses
        , aauPriority = allocationUserPriority
        , aauApplications = Map.empty -- form collects existing applications itself
        }

    editUserAct <- formResultMaybe editUserRes $ \AllocationUserForm{..} -> Just <$> do
      now <- liftIO getCurrentTime
      
      replace auId AllocationUser
        { allocationUserAllocation = aId
        , allocationUserUser = aauUser
        , allocationUserTotalCourses = aauTotalCourses
        , allocationUserPriority = aauPriority
        }
      audit $ TransactionAllocationUserEdited aauUser aId

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

      iforM_ aauApplications $ \cId ApplicationForm{..} -> maybeT_ $ 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 MsgAllocationEditUserUserEdited
        redirect $ AllocationR tid ssh ash AUsersR

    return (alloc, user, (editUserAct, editUserForm, editUserEnctype))

  sequence_ editUserAct

  MsgRenderer mr <- getMsgRenderer
  let title = MsgAllocationEditUserTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationShorthand userDisplayName
      shortTitle = MsgAllocationEditUserShortTitle allocationTerm allocationSchool allocationShorthand userDisplayName

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

getADelUserR, postADelUserR :: TermId -> SchoolId -> AllocationShorthand -> CryptoUUIDUser -> Handler Html
getADelUserR = postADelUserR
postADelUserR tid ssh ash cID = do
  uid <- decrypt cID
  (aId, auId) <- runDB . maybeT notFound $ do
    aId <- MaybeT . getKeyBy $ TermSchoolAllocationShort tid ssh ash
    auId <- MaybeT . getKeyBy $ UniqueAllocationUser aId uid
    return (aId, auId)

  deleteR DeleteRoute
    { drRecords = Set.singleton auId
    , drGetInfo = \(allocationUser `E.InnerJoin` user) -> do
        E.on $ allocationUser E.^. AllocationUserUser E.==. user E.^. UserId

        let appsCount = E.subSelectCount . E.from $ \courseApplication ->
              E.where_ $ courseApplication E.^. CourseApplicationUser E.==. allocationUser E.^. AllocationUserUser
                   E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationUser E.^. AllocationUserAllocation)
            allocsCount = E.subSelectCount . E.from $ \courseParticipant ->
              E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. allocationUser E.^. AllocationUserUser
                   E.&&. courseParticipant E.^. CourseParticipantAllocated E.==. E.just (allocationUser E.^. AllocationUserAllocation)

        return ( ( user E.^. UserDisplayName, user E.^. UserSurname )
               , appsCount :: E.SqlExpr (E.Value Word64)
               , allocsCount :: E.SqlExpr (E.Value Word64)
               )
    , drUnjoin = \(allocationUser `E.InnerJoin` _user) -> allocationUser
    , drRenderRecord = \((E.Value dName, E.Value sName), E.Value (assertM' (> 0) -> appsCount), E.Value (assertM' (> 0) -> allocsCount)) -> return
        [whamlet|
          $newline never
          ^{nameWidget dName sName}
          $if is _Just appsCount || is _Just allocsCount
            \ (
            $maybe c <- appsCount
              _{MsgAllocationApplicationsCount c}
            $if is _Just appsCount || is _Just allocsCount
              , #
            $maybe c <- appsCount
              _{MsgAllocationAllocationsCount c}
            )
        |]
    , drRecordConfirmString = \((E.Value dName, _), _, _) -> return [st|#{dName}|]
    , drFormMessage = \_ -> return Nothing
    , drCaption = SomeMessage MsgAllocationUserDeleteQuestion
    , drSuccessMessage = SomeMessage MsgAllocationUserDeleted
    , drAbort = SomeRoute . AllocationR tid ssh ash $ AEditUserR cID
    , drSuccess = SomeRoute $ AllocationR tid ssh ash AUsersR
    , drDelete = \_k doDelete -> do
        res <- doDelete
        audit $ TransactionAllocationUserDeleted uid aId
        return res
    }