feat(news): active allocations for lecturers
This commit is contained in:
Gregor Kleen
parent
6aacf40125
commit
cde0122529
@ -355,21 +355,11 @@ input[type="button"].btn-info:not(.btn-link):hover,
|
||||
.table__td
|
||||
background-color: rgba(0, 0, 0, 0.03)
|
||||
|
||||
&.table--vertical
|
||||
.table__row:not(.no-stripe):not(.table__row--sum):nth-child(even)
|
||||
.table__th
|
||||
background-color: rgba(0, 0, 0, 0.03)
|
||||
|
||||
.table--hover
|
||||
.table__row:not(.no-hover):not(.table__row--sum):not(.table__row--head):not(.table__row--foot):hover
|
||||
.table__td
|
||||
background-color: rgba(0, 0, 0, 0.07)
|
||||
|
||||
&.table--vertical
|
||||
.table__row:not(.no-hover):not(.table__row--sum):not(.table__row--head):not(.table__row--foot):hover
|
||||
.table__th
|
||||
background-color: rgba(0, 0, 0, 0.07)
|
||||
|
||||
.table__row--sum td.table__td::before
|
||||
content: 'Σ'
|
||||
font-weight: bold
|
||||
@ -431,10 +421,8 @@ input[type="button"].btn-info:not(.btn-link):hover,
|
||||
width: max-content
|
||||
|
||||
.table__th
|
||||
background-color: var(--color-dark)
|
||||
position: relative
|
||||
font-size: 16px
|
||||
color: white
|
||||
line-height: 1.4
|
||||
padding-top: 10px
|
||||
padding-bottom: 10px
|
||||
@ -442,6 +430,10 @@ input[type="button"].btn-info:not(.btn-link):hover,
|
||||
text-align: left
|
||||
vertical-align: middle
|
||||
|
||||
&:not(.table__th--bright)
|
||||
background-color: var(--color-dark)
|
||||
color: white
|
||||
|
||||
a
|
||||
color: white
|
||||
text-decoration: none
|
||||
@ -1460,6 +1452,67 @@ a.breadcrumbs__home
|
||||
&--success
|
||||
border-left-color: var(--color-success)
|
||||
|
||||
|
||||
.active-allocations__wrapper
|
||||
display: flex
|
||||
margin: -7px
|
||||
flex-wrap: wrap
|
||||
|
||||
.active-allocations__allocation
|
||||
margin: 7px
|
||||
display: grid
|
||||
grid-template-columns: auto min-content
|
||||
grid-template-areas: '. ident' 'name name' 'time time' 'data data'
|
||||
border: 1px solid var(--color-grey)
|
||||
padding: 7px
|
||||
min-width: calc((100vw - 40px - 8 * 7px) / 4)
|
||||
|
||||
@media (min-width: 426px)
|
||||
min-width: calc((100vw - var(--asidenav-width-md, 50px) - 40px - 8 * 7px) / 4)
|
||||
@media (min-width: 769px)
|
||||
min-width: calc((100vw - var(--asidenav-width-lg, 20%) - 80px - 8 * 7px) / 4)
|
||||
@media (min-width: 1200px)
|
||||
min-width: calc((100vw - var(--asidenav-width-xl, 250px) - 80px - 8 * 7px) / 4)
|
||||
|
||||
a.active-allocations__allocation-ident
|
||||
white-space: nowrap
|
||||
text-decoration: none
|
||||
color: var(--color-fontsec)
|
||||
font-weight: 600
|
||||
font-size: 0.9rem
|
||||
text-align: right
|
||||
grid-area: ident
|
||||
|
||||
.active-allocations__allocation-name
|
||||
grid-area: name
|
||||
text-align: center
|
||||
|
||||
.active-allocations__allocation-time
|
||||
grid-area: time
|
||||
|
||||
.active-allocations__allocation-info
|
||||
grid-area: data
|
||||
margin: 0
|
||||
|
||||
tbody
|
||||
th
|
||||
text-align: right
|
||||
padding-right: 14px
|
||||
td
|
||||
text-align: center
|
||||
|
||||
thead th
|
||||
text-align: center
|
||||
padding: 5px
|
||||
|
||||
td.active-allocations__allocation-info-item--old
|
||||
font-style: italic
|
||||
color: var(--color-fontsec)
|
||||
|
||||
th.active-allocations__allocation-info-item--old
|
||||
color: var(--color-fontsec)
|
||||
|
||||
|
||||
.faq__question
|
||||
font-size: 18px
|
||||
font-weight: 400
|
||||
|
||||
@ -117,8 +117,10 @@ AllocationSemester !ident-ok: Semester
|
||||
AllocationDescription: Beschreibung
|
||||
AllocationStaffDescription: Beschreibung für Dozierende
|
||||
AllocationStaffRegisterFrom: Eintragung der Kurse ab
|
||||
AllocationStaffRegisterTo: Eintragung der Kurse bis
|
||||
AllocationStaffRegister: Eintragung der Kurse
|
||||
AllocationStaffAllocationFrom: Bewertung der Bewerbungen ab
|
||||
AllocationStaffAllocationTo: Bewertung der Bewerbungen bis
|
||||
AllocationStaffAllocation: Bewertung der Bewerbungen
|
||||
AllocationRegisterFrom: Bewerbung ab
|
||||
AllocationRegister: Bewerbung
|
||||
@ -126,6 +128,7 @@ AllocationRegisterClosed: Die Zentralanmeldung ist aktuell geschlossen.
|
||||
AllocationRegisterOpensIn difftime@Text: Die Zentralanmeldung öffnet voraussichtlich in #{difftime}
|
||||
AllocationRegisterByStaff: An- und Abmeldung durch Kursverwalter:in
|
||||
AllocationRegisterByStaffFrom: An- und Abmeldung durch Kursverwalter:in ab
|
||||
AllocationRegisterByStaffTo: An- und Abmeldung durch Kursverwalter:in bis
|
||||
AllocationRegisterByStaffTip: In diesem Zeitraum können Kursverwalter:innen Teilnehmer:innen zu und von ihren Kursen an- und abmelden.
|
||||
AllocationRegisterByStaffFromTip: Ab diesem Zeitpunkt können Kursverwalter:innen Teilnehmer:innen zu und von ihren Kursen an- und abmelden.
|
||||
AllocationRegisterByCourseFrom: Direkte An- und Abmeldung ab
|
||||
@ -176,6 +179,8 @@ AllocationFormTerm: Semester
|
||||
AllocationFormSchool: Institut
|
||||
AllocationFormShorthand: Kürzel
|
||||
AllocationFormName !ident-ok: Name
|
||||
AllocationFormLegacyShorthands: Alte Kürzel
|
||||
AllocationFormLegacyShorthandsTip: Zentralanmeldungen werden gelegentlich mit vorherigen Versionen in Bezug gesetzt (z.B. um Kapazität/Auslastung zu vergleichen). Dies geschieht anhand des Kürzels, bzw. anhand der hier angegebenen alten Kürzel. (Komma-separierte Liste)
|
||||
AllocationFormDescriptions: Beschreibungen
|
||||
AllocationFormDescription: Beschreibung
|
||||
AllocationFormDescriptionTip: Wird allen Benutzern auf der Seite der Zentralanmeldung angezeigt
|
||||
|
||||
@ -117,8 +117,10 @@ AllocationSemester: Semester
|
||||
AllocationDescription: Description
|
||||
AllocationStaffDescription: Staff description
|
||||
AllocationStaffRegisterFrom: Registration of courses starts
|
||||
AllocationStaffRegisterTo: Register courses until
|
||||
AllocationStaffRegister: Registration of courses
|
||||
AllocationStaffAllocationFrom: Grading of applications starts
|
||||
AllocationStaffAllocationTo: Rating of applications until
|
||||
AllocationStaffAllocation: Grading of applications
|
||||
AllocationRegisterFrom: Application period start
|
||||
AllocationRegister: Application period
|
||||
@ -126,6 +128,7 @@ AllocationRegisterClosed: This central allocation is currently closed.
|
||||
AllocationRegisterOpensIn difftime: This central allocation is expected to open in #{difftime}
|
||||
AllocationRegisterByStaff: Enrollment by course administrators
|
||||
AllocationRegisterByStaffFrom: Enrollment by course administrators starts
|
||||
AllocationRegisterByStaffTo: Enrollment by course administrators ends
|
||||
AllocationRegisterByStaffTip: In this periods course administrators may enroll participants in their courses.
|
||||
AllocationRegisterByStaffFromTip: Starting at this time course administrators may enroll participants in their courses.
|
||||
AllocationRegisterByCourseFrom: Direct enrollment starts
|
||||
@ -175,6 +178,8 @@ AllocationFormTerm: Term
|
||||
AllocationFormSchool: Department
|
||||
AllocationFormShorthand: Shorthand
|
||||
AllocationFormName: Name
|
||||
AllocationFormLegacyShorthands: Legacy shorthands
|
||||
AllocationFormLegacyShorthandsTip: Allocations are occasionally related to previous versions (e.g. to compare capacity/utilisation). This is done via their shorthand and via the legacy shorthands given here. (Comma-separated list)
|
||||
AllocationFormDescriptions: Description
|
||||
AllocationFormDescription: Description
|
||||
AllocationFormDescriptionTip: Will be shown to all users on the page of the allocation
|
||||
|
||||
@ -14,3 +14,9 @@ SubmissionNew: Abgabe anlegen
|
||||
NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter
|
||||
NoUpcomingExams difftime@Text: In den nächsten #{difftime} gibt es keine Prüfungen oder ablaufende Prüfungsanmeldungen in Ihren Kursen
|
||||
CourseParticipant: Teilnehmer:in
|
||||
|
||||
NewsActiveAllocations: Aktive Zentralanmeldungen (für Dozenten)
|
||||
NewsActiveAllocationsPlaces: Plätze
|
||||
NewsActiveAllocationsApplicants: Bewerber
|
||||
NewsActiveAllocationsPlacementsMade: Zugeteilte Plätze
|
||||
NewsActiveAllocationsApplicantsPlaced: Zugeteilte Bewerber
|
||||
@ -14,3 +14,9 @@ SubmissionNew: Create submission
|
||||
NoUpcomingSheetDeadlines: No upcoming sheets
|
||||
NoUpcomingExams difftime: No exams for your courses occur or allow registration in the next #{difftime}
|
||||
CourseParticipant: Participant
|
||||
|
||||
NewsActiveAllocations: Active allocations (for lecturers)
|
||||
NewsActiveAllocationsPlaces: Places
|
||||
NewsActiveAllocationsApplicants: Applicants
|
||||
NewsActiveAllocationsPlacementsMade: Placements made
|
||||
NewsActiveAllocationsApplicantsPlaced: Applicants placed
|
||||
|
||||
@ -3,6 +3,7 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis
|
||||
school SchoolId -- school that manages this central allocation, not necessarily school of courses
|
||||
shorthand AllocationShorthand -- practical shorthand
|
||||
name AllocationName
|
||||
legacyShorthands [AllocationShorthand] default='[]' -- just for association to previous allocations
|
||||
description StoredMarkup Maybe -- description for prospective students
|
||||
staffDescription StoredMarkup Maybe -- description seen by prospective lecturers only
|
||||
staffRegisterFrom UTCTime Maybe -- lectureres may register courses
|
||||
@ -19,7 +20,7 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis
|
||||
registerByStaffFrom UTCTime Maybe -- lecturers may directly enrol/disenrol students after a given date or prohibited
|
||||
registerByStaffTo UTCTime Maybe
|
||||
registerByCourse UTCTime Maybe -- course registration dates are ignored until this day has passed or always prohibited
|
||||
overrideDeregister UTCTime Maybe -- course deregistration enforced to be this date, i.e. students may disenrol from course after or never
|
||||
overrideDeregister UTCTime Maybe -- deregister prohibited after this time or always allowed (defaulting to course settings)
|
||||
-- overrideVisible not needed, since courses are always visible
|
||||
matchingSeed ByteString default='\x'::bytea
|
||||
TermSchoolAllocationShort term school shorthand -- shorthand must be unique within school and semester
|
||||
@ -38,6 +39,7 @@ AllocationCourse
|
||||
course CourseId
|
||||
minCapacity Int -- if the course would get assigned fewer than this many applicants, restart the assignment process without the course
|
||||
acceptSubstitutes UTCTime Maybe
|
||||
overrideSumCapacity Int Maybe -- mark course as outlier (ridiculously large capacity) and use this capacity instead for computing overall capacity of allocation
|
||||
UniqueAllocationCourse course
|
||||
deriving Generic
|
||||
|
||||
|
||||
@ -28,7 +28,7 @@ module Database.Esqueleto.Utils
|
||||
, (->.), (#>>.)
|
||||
, fromSqlKey
|
||||
, unKey
|
||||
, selectCountRows
|
||||
, selectCountRows, selectCountDistinct
|
||||
, selectMaybe
|
||||
, day, diffDays, diffTimes
|
||||
, exprLift
|
||||
@ -436,6 +436,15 @@ selectCountRows q = do
|
||||
_other
|
||||
-> error "E.countRows did not return exactly one result"
|
||||
|
||||
selectCountDistinct :: (Num a, PersistField a, MonadIO m) => E.SqlQuery (E.SqlExpr (E.Value typ)) -> E.SqlReadT m a
|
||||
selectCountDistinct q = do
|
||||
res <- E.select $ E.countDistinct <$> q
|
||||
case res of
|
||||
[E.Value res']
|
||||
-> return res'
|
||||
_other
|
||||
-> error "E.countDistinct did not return exactly one result"
|
||||
|
||||
selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r)
|
||||
selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1)
|
||||
|
||||
|
||||
@ -7,6 +7,8 @@ import Handler.Utils
|
||||
|
||||
import Handler.Allocation.Form
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
||||
getAEditR, postAEditR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
|
||||
getAEditR = postAEditR
|
||||
@ -19,6 +21,7 @@ postAEditR tid ssh ash = do
|
||||
, afSchool = allocationSchool
|
||||
, afShorthand = allocationShorthand
|
||||
, afName = allocationName
|
||||
, afLegacyShorthands = Set.fromList allocationLegacyShorthands
|
||||
, afDescription = allocationDescription
|
||||
, afStaffDescription = allocationStaffDescription
|
||||
, afStaffRegisterFrom = allocationStaffRegisterFrom
|
||||
@ -41,6 +44,7 @@ postAEditR tid ssh ash = do
|
||||
, allocationSchool = afSchool
|
||||
, allocationShorthand = afShorthand
|
||||
, allocationName = afName
|
||||
, allocationLegacyShorthands = Set.toList afLegacyShorthands
|
||||
, allocationDescription = afDescription
|
||||
, allocationStaffDescription = afStaffDescription
|
||||
, allocationStaffRegisterFrom = afStaffRegisterFrom
|
||||
|
||||
@ -13,6 +13,9 @@ import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import qualified Control.Monad.State.Class as State
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Text as Text
|
||||
|
||||
|
||||
data AllocationForm = AllocationForm
|
||||
@ -20,6 +23,7 @@ data AllocationForm = AllocationForm
|
||||
, afSchool :: SchoolId
|
||||
, afShorthand :: AllocationShorthand
|
||||
, afName :: AllocationName
|
||||
, afLegacyShorthands :: Set AllocationShorthand
|
||||
, afDescription, afStaffDescription :: Maybe StoredMarkup
|
||||
, afStaffRegisterFrom, afStaffRegisterTo
|
||||
, afRegisterFrom, afRegisterTo
|
||||
@ -68,11 +72,15 @@ allocationForm mTemplate = validateAForm validateAllocationForm . wFormToAForm $
|
||||
|
||||
template <- maybe (lift . lift $ suggestAllocationForm termOptions schoolOptions) (return . Just) mTemplate
|
||||
|
||||
let cfCommaSeparatedSet :: forall m. Functor m => Field m Text -> Field m (Set (CI Text))
|
||||
cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (fmap CI.mk . assertM' (not . Text.null) . Text.strip) . Text.splitOn ",") (Text.intercalate ", " . map CI.original . Set.toList)
|
||||
|
||||
aFormToWForm . hoistAForm liftHandler $ AllocationForm
|
||||
<$> areq (selectField $ return termOptions) (fslI MsgAllocationFormTerm) (afTerm <$> template)
|
||||
<*> areq (selectField $ return schoolOptions) (fslI MsgAllocationFormSchool) (afSchool <$> template)
|
||||
<*> areq (textField & cfStrip & cfCI) (fslI MsgAllocationFormShorthand) (afShorthand <$> template)
|
||||
<*> areq (textField & cfStrip & cfCI) (fslI MsgAllocationFormName) (afName <$> template)
|
||||
<*> (fromMaybe Set.empty <$> aopt (textField & cfCommaSeparatedSet) (fslI MsgAllocationFormLegacyShorthands & setTooltip MsgAllocationFormLegacyShorthandsTip) (fmap Just $ afLegacyShorthands <$> template))
|
||||
<* aformSection MsgAllocationFormDescriptions
|
||||
<*> aopt htmlField (fslI MsgAllocationFormDescription & setTooltip MsgAllocationFormDescriptionTip) (afDescription <$> template)
|
||||
<*> aopt htmlField (fslI MsgAllocationFormStaffDescription & setTooltip MsgAllocationFormStaffDescriptionTip) (afStaffDescription <$> template)
|
||||
@ -90,6 +98,8 @@ allocationForm mTemplate = validateAForm validateAllocationForm . wFormToAForm $
|
||||
|
||||
validateAllocationForm :: FormValidator AllocationForm (YesodDB UniWorX) ()
|
||||
validateAllocationForm = do
|
||||
State.modify $ \af -> af { afLegacyShorthands = Set.delete (afShorthand af) $ afLegacyShorthands af }
|
||||
|
||||
AllocationForm{..} <- State.get
|
||||
|
||||
guardValidation MsgAllocationFormStaffRegisterToMustBeAfterFrom
|
||||
@ -157,6 +167,7 @@ suggestAllocationForm (Set.fromList . map optionInternalValue . olOptions -> ter
|
||||
, afSchool = ssh
|
||||
, afShorthand = ash
|
||||
, afName = allocationName
|
||||
, afLegacyShorthands = Set.delete ash $ Set.fromList allocationLegacyShorthands
|
||||
, afDescription = allocationDescription
|
||||
, afStaffDescription = allocationStaffDescription
|
||||
, afStaffRegisterFrom = addTime <$> allocationStaffRegisterFrom
|
||||
|
||||
@ -9,6 +9,8 @@ import Handler.Allocation.Form
|
||||
|
||||
import qualified Crypto.Random as Crypto
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
||||
getAllocationNewR, postAllocationNewR :: Handler Html
|
||||
getAllocationNewR = postAllocationNewR
|
||||
@ -24,6 +26,7 @@ postAllocationNewR = do
|
||||
, allocationSchool = afSchool
|
||||
, allocationShorthand = afShorthand
|
||||
, allocationName = afName
|
||||
, allocationLegacyShorthands = Set.toList afLegacyShorthands
|
||||
, allocationDescription = afDescription
|
||||
, allocationStaffDescription = afStaffDescription
|
||||
, allocationStaffRegisterFrom = afStaffRegisterFrom
|
||||
|
||||
@ -595,10 +595,11 @@ upsertAllocationCourse cid = \case
|
||||
prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
|
||||
|
||||
void $ upsert AllocationCourse
|
||||
{ allocationCourseAllocation = acfAllocation
|
||||
, allocationCourseCourse = cid
|
||||
, allocationCourseMinCapacity = acfMinCapacity
|
||||
, allocationCourseAcceptSubstitutes = acfAcceptSubstitutes
|
||||
{ allocationCourseAllocation = acfAllocation
|
||||
, allocationCourseCourse = cid
|
||||
, allocationCourseMinCapacity = acfMinCapacity
|
||||
, allocationCourseAcceptSubstitutes = acfAcceptSubstitutes
|
||||
, allocationCourseOverrideSumCapacity = Nothing
|
||||
}
|
||||
[ AllocationCourseAllocation =. acfAllocation
|
||||
, AllocationCourseCourse =. cid
|
||||
|
||||
@ -1,13 +1,15 @@
|
||||
module Handler.News where
|
||||
|
||||
import Import
|
||||
import Import hiding (maximum, minimum, minimumBy)
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.News
|
||||
|
||||
import Handler.SystemMessage
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Database.Esqueleto.Utils.TH
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
@ -20,6 +22,8 @@ import qualified Data.HashMap.Strict as HashMap
|
||||
|
||||
import Handler.Utils.Exam (showExamOccurrenceRoom)
|
||||
|
||||
import Data.List (maximum, minimum, minimumBy)
|
||||
|
||||
|
||||
getNewsR :: Handler Html
|
||||
getNewsR = do
|
||||
@ -34,6 +38,7 @@ getNewsR = do
|
||||
|
||||
case muid of
|
||||
Just uid -> do
|
||||
newsActiveAllocations uid
|
||||
newsUpcomingExams uid
|
||||
newsUpcomingSheets uid
|
||||
Nothing ->
|
||||
@ -346,3 +351,165 @@ newsUpcomingExams uid = do
|
||||
$(widgetFile "news/upcomingExams")
|
||||
|
||||
|
||||
data AllocationUtilInfo = AllocationUtilInfo
|
||||
{ auiApplicants
|
||||
, auiPlaces
|
||||
, auiPlacementsMade
|
||||
, auiApplicantsPlaced :: Word64
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
newsActiveAllocations :: UserId -> Widget
|
||||
newsActiveAllocations uid = maybeT_ $ do
|
||||
now <- liftIO getCurrentTime
|
||||
activeAllocs <- hoist (liftHandler . runDB) $ do
|
||||
guardM . lift $ or2M (hasWriteAccessTo CourseNewR) (hasWriteAccessTo AllocationNewR)
|
||||
|
||||
userSchools <- lift . fmap (map E.unValue) . E.select . E.from $ \userSchool -> E.distinctOnOrderBy [E.asc $ userSchool E.^. UserSchoolSchool] $ do
|
||||
E.where_ $ userSchool E.^. UserSchoolUser E.==. E.val uid
|
||||
return $ userSchool E.^. UserSchoolSchool
|
||||
functionSchools <- lift . fmap (map E.unValue) . E.select . E.from $ \userFunction -> E.distinctOnOrderBy [E.asc $ userFunction E.^. UserFunctionSchool] $ do
|
||||
E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
|
||||
E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolAllocation
|
||||
return $ userFunction E.^. UserFunctionSchool
|
||||
|
||||
let allocSchools = Set.fromList $ userSchools <> functionSchools
|
||||
|
||||
guard . not $ null allocSchools
|
||||
|
||||
activeAllocs <- lift . E.select . E.from $ \allocation -> do
|
||||
E.where_ $ allocation E.^. AllocationSchool `E.in_` E.valList (Set.toList allocSchools)
|
||||
E.where_ $ E.maybe E.false (E.<=. E.val now) (allocation E.^. AllocationStaffRegisterFrom) E.&&. E.maybe E.true (E.>=. E.val now) (allocation E.^. AllocationStaffRegisterTo)
|
||||
E.||. E.maybe E.false (E.<=. E.val now) (allocation E.^. AllocationStaffAllocationFrom) E.&&. E.maybe E.true (E.>=. E.val now) (allocation E.^. AllocationStaffAllocationTo)
|
||||
E.||. E.maybe E.false (E.<=. E.val now) (allocation E.^. AllocationRegisterFrom) E.&&. E.maybe E.true (E.>=. E.val now) (allocation E.^. AllocationRegisterTo)
|
||||
E.||. E.maybe E.true (E.>=. E.val now) (allocation E.^. AllocationRegisterByStaffFrom) E.||. E.maybe E.false (E.<=. E.val now) (allocation E.^. AllocationRegisterByStaffTo)
|
||||
E.||. E.maybe E.false (E.>=. E.val now) (allocation E.^. AllocationRegisterByCourse)
|
||||
|
||||
return allocation
|
||||
|
||||
guard . not $ null activeAllocs
|
||||
|
||||
fmap Map.fromList . forM activeAllocs $ \activeAlloc'@(Entity _ activeAlloc) -> lift $ ((allocationTerm activeAlloc, allocationSchool activeAlloc, allocationShorthand activeAlloc), ) <$> do
|
||||
prevAllocs <- E.select . E.from $ \allocation -> E.distinctOnOrderBy [ E.desc $ allocation E.^. AllocationTerm ] $ do
|
||||
E.where_ $ allocation E.^. AllocationShorthand `E.in_` E.valList (allocationShorthand activeAlloc : allocationLegacyShorthands activeAlloc)
|
||||
E.&&. allocation E.^. AllocationTerm E.<. E.val (allocationTerm activeAlloc)
|
||||
E.&&. allocation E.^. AllocationSchool E.==. E.val (allocationSchool activeAlloc)
|
||||
E.orderBy [E.asc $ allocation E.^. AllocationSchool]
|
||||
E.limit 2
|
||||
return allocation
|
||||
|
||||
let allocInfo :: Entity Allocation -> DB (Entity Allocation, AllocationUtilInfo)
|
||||
allocInfo ent@(Entity aId' _) = (ent, ) <$> do
|
||||
auiApplicants <- E.selectCountRows . E.from $ \allocationUser -> do
|
||||
E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val aId'
|
||||
E.where_ $ allocationUser E.^. AllocationUserTotalCourses E.>=. E.val 1 -- wants at least one course
|
||||
E.where_ . E.exists . E.from $ \(courseApplication `E.InnerJoin` allocationCourse) -> do -- at least one application
|
||||
E.on $ courseApplication E.^. CourseApplicationCourse E.==. allocationCourse E.^. AllocationCourseCourse
|
||||
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId'
|
||||
E.where_ $ courseApplication E.^. CourseApplicationUser E.==. allocationUser E.^. AllocationUserUser
|
||||
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.justVal aId'
|
||||
auiPlaces <- fmap (fromMaybe 0 . (E.unValue =<<)) . E.selectMaybe . E.from $ \(allocationCourse `E.InnerJoin` course) -> do
|
||||
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
||||
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId'
|
||||
return . E.explicitUnsafeCoerceSqlExprValue @(Maybe Word64) @(Maybe Rational) "integer" . E.sum_ . E.maybe (E.val 0) id . E.maybe (course E.^. CourseCapacity) E.just $ allocationCourse E.^. AllocationCourseOverrideSumCapacity
|
||||
placementsCounts <- E.select . E.from $ \(courseParticipant `E.InnerJoin` allocationCourse) -> do
|
||||
E.on $ courseParticipant E.^. CourseParticipantCourse E.==. allocationCourse E.^. AllocationCourseCourse
|
||||
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId'
|
||||
E.where_ . E.isJust $ courseParticipant E.^. CourseParticipantAllocated -- count any allocations; course can only be in one allocation at a time
|
||||
return ( E.countRows
|
||||
, E.countDistinct $ courseParticipant E.^. CourseParticipantUser
|
||||
)
|
||||
let (auiPlacementsMade, auiApplicantsPlaced) = case placementsCounts of
|
||||
[(E.Value placementsMade, E.Value applicantsPlaced)] -> (placementsMade, applicantsPlaced)
|
||||
_other -> error "Query `SELECT COUNT(*), COUNT(DISTINCT …) …` did not return exactly one row"
|
||||
return AllocationUtilInfo{..}
|
||||
|
||||
(:|) <$> allocInfo activeAlloc'
|
||||
<*> traverse allocInfo prevAllocs
|
||||
|
||||
let allocsToList allocs = toList allocs
|
||||
& sortOn (Down . allocationTerm . views _1 entityVal)
|
||||
allocationInfo = $(i18nWidgetFile "news/activeAllocations-info")
|
||||
allocTime Allocation{..} | null timeOpts' = Nothing
|
||||
| otherwise = Just . view _2 $ minimumBy (comparing $ view _1) timeOpts'
|
||||
where
|
||||
timeOpts' = flip mapMaybe timeOpts $ \(ts, w)
|
||||
-> let ts' = flip mapMaybe ts $ \mt -> assertM' (>= 0) . (`diffUTCTime` now) =<< mt
|
||||
in if | null ts' -> Nothing
|
||||
| otherwise -> Just (minimum ts', w)
|
||||
timeOpts = catMaybes
|
||||
[ allocationRegisterByStaffFrom <&> \registerByStaffFrom ->
|
||||
( [allocationRegisterByStaffFrom, allocationRegisterByStaffTo]
|
||||
, [whamlet|
|
||||
$newline never
|
||||
_{MsgAllocationRegisterByStaff}: #
|
||||
^{formatTimeRangeW (selFormat $ catMaybes [allocationRegisterByStaffFrom, allocationRegisterByStaffTo]) registerByStaffFrom allocationRegisterByStaffTo}
|
||||
|]
|
||||
)
|
||||
, allocationRegisterByStaffTo <&> \registerByStaffTo ->
|
||||
( [allocationRegisterByStaffTo]
|
||||
, [whamlet|
|
||||
$newline never
|
||||
_{MsgAllocationRegisterByStaffTo}: #
|
||||
^{formatTimeW (selFormat $ catMaybes [allocationRegisterByStaffTo]) registerByStaffTo}
|
||||
|]
|
||||
)
|
||||
, allocationStaffRegisterFrom <&> \staffRegisterFrom ->
|
||||
( [allocationStaffRegisterFrom, allocationStaffRegisterTo]
|
||||
, [whamlet|
|
||||
$newline never
|
||||
_{MsgAllocationStaffRegister}: #
|
||||
^{formatTimeRangeW (selFormat $ catMaybes [allocationStaffRegisterFrom, allocationStaffRegisterTo]) staffRegisterFrom allocationStaffRegisterTo}
|
||||
|]
|
||||
)
|
||||
, allocationStaffRegisterTo <&> \staffRegisterTo ->
|
||||
( [allocationStaffRegisterTo]
|
||||
, [whamlet|
|
||||
$newline never
|
||||
_{MsgAllocationStaffRegisterTo}: #
|
||||
^{formatTimeW (selFormat $ catMaybes [allocationStaffRegisterTo]) staffRegisterTo}
|
||||
|]
|
||||
)
|
||||
, allocationRegisterFrom <&> \registerFrom ->
|
||||
( [allocationRegisterFrom, allocationRegisterTo]
|
||||
, [whamlet|
|
||||
$newline never
|
||||
_{MsgAllocationRegister}: #
|
||||
^{formatTimeRangeW (selFormat $ catMaybes [allocationRegisterFrom, allocationRegisterTo]) registerFrom allocationRegisterTo}
|
||||
|]
|
||||
)
|
||||
, allocationRegisterTo <&> \registerTo ->
|
||||
( [allocationRegisterTo]
|
||||
, [whamlet|
|
||||
$newline never
|
||||
_{MsgAllocationRegisterTo}: #
|
||||
^{formatTimeW (selFormat $ catMaybes [allocationRegisterTo]) registerTo}
|
||||
|]
|
||||
)
|
||||
, allocationStaffAllocationFrom <&> \staffAllocationFrom ->
|
||||
( [allocationStaffAllocationFrom, allocationStaffAllocationTo]
|
||||
, [whamlet|
|
||||
$newline never
|
||||
_{MsgAllocationStaffAllocation}: #
|
||||
^{formatTimeRangeW (selFormat $ catMaybes [allocationStaffAllocationFrom, allocationStaffAllocationTo]) staffAllocationFrom allocationStaffAllocationTo}
|
||||
|]
|
||||
)
|
||||
, allocationStaffAllocationTo <&> \staffAllocationTo ->
|
||||
( [allocationStaffAllocationTo]
|
||||
, [whamlet|
|
||||
$newline never
|
||||
_{MsgAllocationStaffAllocationTo}: #
|
||||
^{formatTimeW (selFormat $ catMaybes [allocationStaffAllocationTo]) staffAllocationTo}
|
||||
|]
|
||||
)
|
||||
]
|
||||
selFormat ts | not $ null ts = maximum $ map selFormat' ts
|
||||
| otherwise = SelFormatDate
|
||||
where selFormat' (utcToLocalTime -> t@LocalTime{..})
|
||||
| closeToEndOfDay = SelFormatDate
|
||||
| otherwise = SelFormatDateTime
|
||||
where closeToEndOfDay = any (\t' -> abs (t `diffLocalTime` t') <= 5 * nominalMinute)
|
||||
[ LocalTime localDay midnight
|
||||
, LocalTime (addDays 1 localDay) midnight
|
||||
]
|
||||
|
||||
lift $(widgetFile "news/activeAllocations")
|
||||
|
||||
@ -118,7 +118,7 @@ import Network.HTTP.Types.Header
|
||||
|
||||
import Data.Time.Clock
|
||||
|
||||
import Data.List.NonEmpty (NonEmpty, nonEmpty)
|
||||
import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
|
||||
|
||||
import Algebra.Lattice (top, bottom, (/\), (\/), BoundedJoinSemiLattice, BoundedMeetSemiLattice)
|
||||
|
||||
@ -562,6 +562,10 @@ withoutSubsequenceBy cmp = go []
|
||||
go acc a@(x:a') (y:b)
|
||||
| x `cmp` y = go acc a' b
|
||||
| otherwise = go (y:acc) a b
|
||||
|
||||
pattern NonEmpty :: forall a. a -> [a] -> NonEmpty a
|
||||
pattern NonEmpty x xs = x :| xs
|
||||
{-# COMPLETE NonEmpty #-}
|
||||
|
||||
----------
|
||||
-- Sets --
|
||||
|
||||
@ -0,0 +1,20 @@
|
||||
$newline never
|
||||
<p .explanation>
|
||||
|
||||
Die Zahlen der jeweils aktiven Zentralanmeldung können sich #
|
||||
jederzeit ändern.
|
||||
|
||||
<br>
|
||||
|
||||
Es werden i.A. auch die aktuellen Zahlen vergangener #
|
||||
Zentralanmeldungen angezeigt um den aktuellen Zustand in Kontext zu #
|
||||
setzen.
|
||||
|
||||
<br>
|
||||
|
||||
Sie können diese Auflistung als Anhaltspunkt verwenden um grob #
|
||||
abzuschätzen ob die aktuell zur Verfügung stehende Kapazität #
|
||||
ausreichen wird oder ob es notwendig ist weitere Kurse anzubieten (es #
|
||||
handelt sich hierbei natürlich nur um einen Orienterungswert und #
|
||||
ersetzt nicht den Weisungen des jeweiligen Instituts in Bezug auf #
|
||||
die anzubietenden Kurse zu folgen).
|
||||
54
templates/news/activeAllocations.hamlet
Normal file
54
templates/news/activeAllocations.hamlet
Normal file
@ -0,0 +1,54 @@
|
||||
$newline never
|
||||
<section .news__active-allocations>
|
||||
<h2>_{MsgNewsActiveAllocations}
|
||||
|
||||
<div .active-allocations__wrapper>
|
||||
$forall allocs@(NonEmpty (Entity cId cAlloc, _) oldAllocs) <- toList activeAllocs
|
||||
$with (tid, ssh, ash) <- (allocationTerm cAlloc, allocationSchool cAlloc, allocationShorthand cAlloc)
|
||||
<div .active-allocations__allocation>
|
||||
<a href=@{AllocationR tid ssh ash AShowR} .active-allocations__allocation-ident>
|
||||
#{toPathPiece tid}
|
||||
-
|
||||
#{ssh}
|
||||
-
|
||||
#{ash}
|
||||
<a href=@{AllocationR tid ssh ash AShowR} .active-allocations__allocation-name>
|
||||
#{allocationName cAlloc}
|
||||
$maybe tWidget <- allocTime cAlloc
|
||||
<div .active-allocations__allocation-time>
|
||||
^{tWidget}
|
||||
<table .active-allocations__allocation-info .table .table--hover .table--condensed>
|
||||
$if not (null oldAllocs)
|
||||
<thead>
|
||||
<tr .table__row--head>
|
||||
<td>
|
||||
$forall (Entity aId alloc, _) <- allocsToList allocs
|
||||
<th .table__th .table__th--bright :aId == cId:.active-allocations__allocation-info-item--current :aId /= cId:.active-allocations__allocation-info-item--old>
|
||||
#{toPathPiece (allocationTerm alloc)}
|
||||
<tbody>
|
||||
<tr .table__row>
|
||||
<th .table__th .table__th--bright>
|
||||
_{MsgNewsActiveAllocationsPlaces}
|
||||
$forall (Entity aId _, allocInfo) <- allocsToList allocs
|
||||
<td .table__td :aId == cId:.active-allocations__allocation-info-item--current :aId /= cId:.active-allocations__allocation-info-item--old>
|
||||
#{auiPlaces allocInfo}
|
||||
<tr .table__row>
|
||||
<th .table__th .table__th--bright>
|
||||
_{MsgNewsActiveAllocationsApplicants}
|
||||
$forall (Entity aId _, allocInfo) <- allocsToList allocs
|
||||
<td .table__td :aId == cId:.active-allocations__allocation-info-item--current :aId /= cId:.active-allocations__allocation-info-item--old>
|
||||
#{auiApplicants allocInfo}
|
||||
<tr .table__row>
|
||||
<th .table__th .table__th--bright>
|
||||
_{MsgNewsActiveAllocationsPlacementsMade}
|
||||
$forall (Entity aId _, allocInfo) <- allocsToList allocs
|
||||
<td .table__td :aId == cId:.active-allocations__allocation-info-item--current :aId /= cId:.active-allocations__allocation-info-item--old>
|
||||
#{auiPlacementsMade allocInfo}
|
||||
<tr .table__row>
|
||||
<th .table__th .table__th--bright>
|
||||
_{MsgNewsActiveAllocationsApplicantsPlaced}
|
||||
$forall (Entity aId _, allocInfo) <- allocsToList allocs
|
||||
<td .table__td :aId == cId:.active-allocations__allocation-info-item--current :aId /= cId:.active-allocations__allocation-info-item--old>
|
||||
#{auiApplicantsPlaced allocInfo}
|
||||
|
||||
^{allocationInfo}
|
||||
@ -1090,6 +1090,7 @@ fillDb = do
|
||||
, allocationShorthand = "fun"
|
||||
, allocationTerm = TermKey $ seasonTerm True Summer
|
||||
, allocationSchool = ifi
|
||||
, allocationLegacyShorthands = []
|
||||
, allocationDescription = Nothing
|
||||
, allocationStaffDescription = Nothing
|
||||
, allocationStaffRegisterFrom = Just now
|
||||
@ -1224,6 +1225,7 @@ fillDb = do
|
||||
, allocationShorthand = "big"
|
||||
, allocationTerm = TermKey $ seasonTerm True Summer
|
||||
, allocationSchool = ifi
|
||||
, allocationLegacyShorthands = []
|
||||
, allocationDescription = Nothing
|
||||
, allocationStaffDescription = Nothing
|
||||
, allocationStaffRegisterFrom = Just now
|
||||
|
||||
Loading…
Reference in New Issue
Block a user