feat(allocations): admin-interface registrations

Fixes #677
2021-06-16 18:15:22 +02:00 · 2021-06-16 18:15:22 +02:00 · 5e38f03a85
commit 5e38f03a85
parent 6da8ad3481
15 changed files with 262 additions and 30 deletions
--- a/frontend/src/app.sass
+++ b/frontend/src/app.sass
@ -593,7 +593,7 @@ section
  & + section, & + .two-column-sections
    margin-top: 20px

-  &:last-child
+  &:last-of-type
    border-bottom: none
    padding-bottom: 0px

@ -604,7 +604,7 @@ section
  & + section, & + .two-column-sections
    margin-top: 20px

-  &:last-child
+  &:last-of-type
    border-bottom: none
    padding-bottom: 0px

--- a/messages/uniworx/categories/courses/allocation/de-de-formal.msg
+++ b/messages/uniworx/categories/courses/allocation/de-de-formal.msg
@ -248,4 +248,12 @@ AllocationUserDeleteQuestion: Wollen Sie den/die unten aufgeführten Benutzer:in
 AllocationUserDeleted: Benutzer:in erfolgreich entfernt
 AllocationApplicationsCount n@Word64: #{n} #{pluralDE n "Bewerbung" "Bewerbungen"}
 AllocationAllocationsCount n@Word64: #{n} #{pluralDE n "Zuweisung" "Zuweisungen"}
-AllocationCourseHasRatings ratings@Word64 vetos@Word64: Dieser Kurs hat bereits #{ratings} #{pluralDE ratings "Bewertung" "Bewertungen"} (#{vetos} #{pluralDE vetos "Veto" "Vetos"})
+AllocationCourseHasRatings ratings@Word64 vetos@Word64: Dieser Kurs hat bereits #{ratings} #{pluralDE ratings "Bewertung" "Bewertungen"} (#{vetos} #{pluralDE vetos "Veto" "Vetos"})
+
+AllocationCourseParticipantFormCourse: Kurs
+AllocationCourseParticipantFormIsRegistered: Registriert?
+AllocationCourseParticipantFormIsSelfInflicted: Selbstverschuldet abgemeldet (Grund)?
+AllocationCourseParticipantFormDefaultReason: Kein Grund
+
+AllocationUserCourseParticipantFormTitle: Anmeldungen
+AllocationUserAllocationUserFormTitle: Teilnahme an der Zentralanmeldung
--- a/messages/uniworx/categories/courses/allocation/en-eu.msg
+++ b/messages/uniworx/categories/courses/allocation/en-eu.msg
@ -248,3 +248,11 @@ AllocationUserDeleted: Participant successfully removed
 AllocationApplicationsCount n: #{n} #{pluralENs n "application"}
 AllocationAllocationsCount n: #{n} #{pluralENs n "allocation"}
 AllocationCourseHasRatings ratings vetos: This course already has #{ratings} #{pluralENs ratings "rating"} (#{vetos} #{pluralENs vetos "veto"})
+
+AllocationCourseParticipantFormCourse: Course
+AllocationCourseParticipantFormIsRegistered: Registered?
+AllocationCourseParticipantFormIsSelfInflicted: Deregistration “self inflicted” (reason)?
+AllocationCourseParticipantFormDefaultReason: No Reason
+
+AllocationUserCourseParticipantFormTitle: Course registrations
+AllocationUserAllocationUserFormTitle: Participation in allocation
--- a/src/Foundation/I18n.hs
+++ b/src/Foundation/I18n.hs
@ -513,7 +513,7 @@ unRenderMessage' cmp foundation inp = nub $ do
 unRenderMessage :: (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a]
 unRenderMessage = unRenderMessage' (==)

-unRenderMessageLenient :: (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a]
+unRenderMessageLenient :: forall a master. (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a]
 unRenderMessageLenient = unRenderMessage' cmp
  where cmp = (==) `on` mk . under packed (filter Char.isAlphaNum . concatMap unidecode)

--- a/src/Handler/Allocation/Application.hs
+++ b/src/Handler/Allocation/Application.hs
@ -110,8 +110,9 @@ applicationForm maId@(is _Just -> isAlloc) cid muid ApplicationFormMode{..} mcsr
    prioField = selectField' (Just $ SomeMessage MsgAllocationCourseNoApplication) $ return prioOptions

  (prioRes, prioView) <- case (isAlloc, afmApplicant, afmApplicantEdit, mApp) of
-    (True , True , True , Nothing)
-      -> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just oldPrio)
+    (True , True , True , _)
+      | is _Nothing mApp || is _Nothing mcsrf
+        -> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just oldPrio)
    (True , True , True , Just _ )
      -> over (_1 . _FormSuccess) Just . over _2 Just <$> mreq prioField (fslI MsgApplicationPriority) oldPrio
    (True , True , False, _      )
@ -263,6 +264,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
    if
      | BtnAllocationApply <- afAction
      , allowAction afAction
+      , is _Nothing maId || is _Just afPriority
        -> runDB . setSerializable $ do
          haveOld <- exists [ CourseApplicationCourse     ==. cid
                            , CourseApplicationUser       ==. uid
@ -293,6 +295,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
      | is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction
      , allowAction afAction
      , Just appId <- mAppId
+      , is _Nothing maId || is _Just afPriority
        -> runDB . setSerializable $ do
          now <- liftIO getCurrentTime

--- a/src/Handler/Allocation/EditUser.hs
+++ b/src/Handler/Allocation/EditUser.hs
@ -17,36 +17,128 @@ import qualified Data.Conduit.Combinators as C
 import Handler.Utils.Delete

 import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+
+import Handler.Course.Register (deregisterParticipant)
+
+import Jobs.Queue
+
+
+data AllocationCourseParticipantFormDefaultReason = AllocationCourseParticipantFormDefaultReason 
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+
+embedRenderMessage ''UniWorX ''AllocationCourseParticipantFormDefaultReason id


 getAEditUserR, postAEditUserR :: TermId -> SchoolId -> AllocationShorthand -> CryptoUUIDUser -> Handler Html
 getAEditUserR = postAEditUserR
 postAEditUserR tid ssh ash cID = do
-  (Entity _ Allocation{..}, User{..}, (editUserAct, editUserForm, editUserEnctype)) <- runDB $ do
+  (Entity _ Allocation{..}, User{..}, editUserAct, editUserForm, regFormForm, formEnctype) <- runDBJobs $ do
    uid <- decrypt cID
    user <- get404 uid
    alloc@(Entity aId _) <- getBy404 $ TermSchoolAllocationShort tid ssh ash
-    Entity auId AllocationUser{..} <- getBy404 $ UniqueAllocationUser aId uid
+    Entity auId oldAllocationUser@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
-        }
+    regState <- do
+      courses <- E.select . E.from $ \((course `E.InnerJoin` allocationCourse) `E.LeftOuterJoin` courseParticipant `E.LeftOuterJoin` allocationDeregister) -> do
+        E.on $ allocationDeregister E.?. AllocationDeregisterUser E.==. E.justVal uid
+         E.&&. E.joinV (allocationDeregister E.?. AllocationDeregisterCourse) E.==. E.just (allocationCourse E.^. AllocationCourseCourse)
+        E.on $ courseParticipant E.?. CourseParticipantUser E.==. E.justVal uid
+         E.&&. courseParticipant E.?. CourseParticipantCourse E.==. E.just (allocationCourse E.^. AllocationCourseCourse)
+        E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse
+         E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId
+        return ( course E.^. CourseId
+               , ( ( course E.^. CourseTerm
+                   , course E.^. CourseSchool
+                   , course E.^. CourseShorthand
+                   )
+                 , course E.^. CourseName
+                 , ( (       E.joinV (courseParticipant E.?. CourseParticipantAllocated) E.==. E.justVal aId
+                       E.||. E.isNothing (courseParticipant E.?. CourseParticipantId)
+                     , courseParticipant E.?. CourseParticipantState
+                     )
+                   , ( E.isJust $ allocationDeregister E.?. AllocationDeregisterId
+                     , E.joinV $ allocationDeregister E.?. AllocationDeregisterReason
+                     )
+                   )
+                 )
+               )
+      MsgRenderer mr <- getMsgRenderer
+      return $
+        let toRegState (E.Value cId, (ident, E.Value cname, regState'))
+                = (cId, ((tid', ssh', csh), cname, courseRegState))
+              where (E.Value tid', E.Value ssh', E.Value csh) = ident
+                    ((E.Value isAlloc, E.Value mParState), (E.Value isDeregister, E.Value regReason)) = regState'
+                    courseRegState
+                      | not isAlloc = CourseParticipantFormNotAllocated
+                      | isDeregister = CourseParticipantFormDeregistered
+                          { cpfDeregisterReason = Just $ fromMaybe defReason regReason
+                          , cpfEverRegistered = True
+                          }
+                      | mParState == Just CourseParticipantActive = CourseParticipantFormRegistered
+                      | otherwise = CourseParticipantFormDeregistered
+                          { cpfDeregisterReason = Nothing
+                          , cpfEverRegistered = is _Just mParState
+                          }
+                    defReason = [st|<#{mr AllocationCourseParticipantFormDefaultReason}>|]
+         in Map.fromList $ map toRegState courses

-    editUserAct <- formResultMaybe editUserRes $ \AllocationUserForm{..} -> Just <$> do
+    ((formRes, (regFormForm, editUserForm)), formEnctype) <- runFormPost $ \csrf
+      -> let allocForm = renderAForm FormStandard $ 
+               allocationUserForm aId $ Just AllocationUserForm
+                 { aauUser = uid
+                 , aauTotalCourses = allocationUserTotalCourses
+                 , aauPriority = allocationUserPriority
+                 , aauApplications = Map.empty -- form collects existing applications itself
+                 }
+          in (\(regRes, regForm) (editUserRes, editUserForm) -> ((,) <$> regRes <*> editUserRes, (regForm, editUserForm))) <$> courseParticipantForm regState csrf <*> allocForm mempty
+
+    editUserAct <- formResultMaybe formRes $ \(regState', AllocationUserForm{..}) -> Just <$> do
      now <- liftIO getCurrentTime
-      
-      replace auId AllocationUser
-        { allocationUserAllocation = aId
-        , allocationUserUser = aauUser
-        , allocationUserTotalCourses = aauTotalCourses
-        , allocationUserPriority = aauPriority
-        }
-      audit $ TransactionAllocationUserEdited aauUser aId

+      iforM_ (Map.intersectionWith (,) regState' regState) $ \cId (cpf, (_, _, oldCPF)) -> when (cpf /= oldCPF) $ case cpf of
+        CourseParticipantFormNotAllocated -> return ()
+        CourseParticipantFormDeregistered mReason _ -> do
+          hoist liftHandler $ deregisterParticipant uid =<< getJustEntity cId
+
+          app <- getYesod
+          let mReason' = mReason <&> \str -> maybe (Just str) (const Nothing) (listToMaybe $ unRenderMessageLenient @AllocationCourseParticipantFormDefaultReason app str)
+          deleteWhere [AllocationDeregisterUser ==. uid, AllocationDeregisterCourse ==. Just cId]
+          for_ mReason' $ \allocationDeregisterReason ->
+            insert AllocationDeregister
+              { allocationDeregisterCourse = Just cId
+              , allocationDeregisterTime = now
+              , allocationDeregisterUser = uid
+              , allocationDeregisterReason
+              }
+        CourseParticipantFormRegistered -> do
+          void $ upsert CourseParticipant
+            { courseParticipantCourse = cId
+            , courseParticipantUser = uid
+            , courseParticipantAllocated = Just aId
+            , courseParticipantState = CourseParticipantActive
+            , courseParticipantRegistration = now
+            }
+            [ CourseParticipantRegistration =. now
+            , CourseParticipantAllocated =. Just aId
+            , CourseParticipantState =. CourseParticipantActive
+            ]
+          audit $ TransactionCourseParticipantEdit cId uid
+          queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cId
+          
+      let newAllocationUser = AllocationUser
+            { allocationUserAllocation = aId
+            , allocationUserUser = aauUser
+            , allocationUserTotalCourses = aauTotalCourses
+            , allocationUserPriority = aauPriority
+            }
+      when (newAllocationUser /= oldAllocationUser) $ do
+        replace auId newAllocationUser
+        audit $ TransactionAllocationUserEdited aauUser aId
+
+      -- Applications are complicated and it isn't easy to detect if something changed
+      -- Therefore we just always replace...
      oldApps <- selectList [CourseApplicationUser ==. aauUser, CourseApplicationAllocation ==. Just aId] []
      forM_ oldApps $ \(Entity appId CourseApplication{..}) -> do
        deleteWhere [ CourseApplicationFileApplication ==. appId ]
@ -74,9 +166,9 @@ postAEditUserR tid ssh ash cID = do

      return $ do
        addMessageI Success MsgAllocationEditUserUserEdited
-        redirect $ AllocationR tid ssh ash AUsersR
+        redirect . AllocationR tid ssh ash $ AEditUserR cID

-    return (alloc, user, (editUserAct, editUserForm, editUserEnctype))
+    return (alloc, user, editUserAct, editUserForm, regFormForm, formEnctype)

  sequence_ editUserAct

@ -86,10 +178,10 @@ postAEditUserR tid ssh ash cID = do

  siteLayoutMsg title $ do
    setTitleI shortTitle
-    wrapForm editUserForm FormSettings
+    wrapForm $(widgetFile "allocation/edit-user") FormSettings
      { formMethod = POST
      , formAction = Just . SomeRoute . AllocationR tid ssh ash $ AEditUserR cID
-      , formEncoding = editUserEnctype
+      , formEncoding = formEnctype
      , formAttrs = []
      , formSubmit = FormSubmit
      , formAnchor = Nothing :: Maybe Text
--- a/src/Handler/Allocation/UserForm.hs
+++ b/src/Handler/Allocation/UserForm.hs
@ -1,6 +1,10 @@
 module Handler.Allocation.UserForm
  ( AllocationUserForm(..)
  , allocationUserForm
+  , CourseParticipantForm(..)
+  , _CourseParticipantFormNotAllocated, _CourseParticipantFormDeregistered, _CourseParticipantFormRegistered, _cpfDeregisterReason, _cpfEverRegistered
+  , CourseParticipantForm'
+  , courseParticipantForm
  ) where

 import Import
@ -161,3 +165,63 @@ allocationApplicationsForm aId muid courses FieldSettings{..} fvRequired  = form
  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
+        & sortBy (comparing . view $ _1 . _1)
+        & view (folded . _2 . _2)
+  return ( forM lines' $ view _1
+         , $(widgetFile "allocation/user-course-participant-form/layout")
+         )
--- a/src/Handler/Course/Application/Edit.hs
+++ b/src/Handler/Course/Application/Edit.hs
@ -22,9 +22,9 @@ postCAEditR tid ssh csh cID = do

  isAdmin <- case mAlloc of
    Just (Entity _ Allocation{..})
-      -> hasWriteAccessTo $ SchoolR allocationSchool SchoolEditR
+      -> hasWriteAccessTo $ AllocationR allocationTerm allocationSchool allocationShorthand AEditR
    Nothing
-      -> hasWriteAccessTo $ SchoolR courseSchool     SchoolEditR
+      -> hasWriteAccessTo $ SchoolR courseSchool SchoolEditR
  let afmApplicant = uid == courseApplicationUser || isAdmin
  afmLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
  mayEdit <- hasWriteAccessTo $ CApplicationR tid ssh csh cID CAEditR
--- a/src/Import/NoModel.hs
+++ b/src/Import/NoModel.hs
@ -188,6 +188,7 @@ import Data.Bool.Instances as Import ()
 import Data.Encoding.Instances as Import ()
 import Prometheus.Instances as Import ()
 import Yesod.Form.Fields.Instances as Import ()
+import Yesod.Form.Types.Instances as Import ()
 import Data.MonoTraversable.Instances as Import ()
 import Web.Cookie.Instances as Import ()
 import Network.HTTP.Types.Method.Instances as Import ()
--- a/src/Yesod/Form/Types/Instances.hs
+++ b/src/Yesod/Form/Types/Instances.hs
@ -0,0 +1,12 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Yesod.Form.Types.Instances
+  () where
+
+import Yesod.Form.Types
+
+import Data.Default
+
+
+instance Default (FieldSettings site) where
+  def = ""
--- a/templates/allocation/edit-user.hamlet
+++ b/templates/allocation/edit-user.hamlet
@ -0,0 +1,9 @@
+$newline never
+<section>
+  <h2>
+    _{MsgAllocationUserCourseParticipantFormTitle}
+  ^{regFormForm}
+<section>
+  <h2>
+    _{MsgAllocationUserAllocationUserFormTitle}
+  ^{editUserForm}
--- a/templates/allocation/user-course-participant-form/cell.hamlet
+++ b/templates/allocation/user-course-participant-form/cell.hamlet
@ -0,0 +1,8 @@
+$newline never
+<td .table__td .text--center>
+  ^{fvWidget isRegView}
+$maybe siView <- isSelfInflictedView
+  <td .table__td .text--center>
+    ^{fvWidget siView}
+$nothing
+  <td .table__td>
--- a/templates/allocation/user-course-participant-form/layout.hamlet
+++ b/templates/allocation/user-course-participant-form/layout.hamlet
@ -0,0 +1,14 @@
+$newline never
+#{csrf}
+<div .scrolltable .scrolltable--bordered>
+  <table .table .table--hover .table--striped .table--condensed>
+    <thead>
+      <tr .table__row--head>
+        <th .table__th colspan=2>
+          _{MsgAllocationCourseParticipantFormCourse}
+        <th .table__th .text--center>
+          _{MsgAllocationCourseParticipantFormIsRegistered}
+        <th .table__th .text--center>
+          _{MsgAllocationCourseParticipantFormIsSelfInflicted}
+    <tbody>
+      ^{linesWidget}
--- a/templates/allocation/user-course-participant-form/line.hamlet
+++ b/templates/allocation/user-course-participant-form/line.hamlet
@ -0,0 +1,9 @@
+$newline never
+<tr .table__row>
+  <td .table__td>
+    <a href=@{CourseR tid ssh csh CShowR}>
+      #{toPathPiece tid}-#{ssh}-#{csh}
+  <td .table__td>
+    <a href=@{CourseR tid ssh csh CShowR}>
+      #{cname}
+  ^{fCell}
--- a/templates/allocation/user-course-participant-form/not-allocated.hamlet
+++ b/templates/allocation/user-course-participant-form/not-allocated.hamlet
@ -0,0 +1,4 @@
+$newline never
+<td .table__td .text--center>
+  ^{fvWidget isRegView}
+<td .table__td>