diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index 547092e46..d58321527 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -345,6 +345,7 @@ UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut e
UnauthorizedAdminEscalation: Sie sind nicht Administrator für alle Institute, für die dieser Nutzer Administrator oder Veranstalter ist.
UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen.
UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen.
+UnauthorizedAllocationLecturer: Sie sind nicht als Veranstalter für eine Veranstaltung dieser Zentralanmeldung eingetragen.
UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung eingetragen.
UnauthorizedSheetCorrector: Sie sind nicht als Korrektor für dieses Übungsblatt eingetragen.
UnauthorizedCorrectorAny: Sie sind nicht als Korrektor für eine Veranstaltung eingetragen.
@@ -352,6 +353,7 @@ UnauthorizedRegistered: Sie sind nicht als Teilnehmer für diese Veranstaltung r
UnauthorizedExamResult: Sie haben keine Ergebnisse in dieser Prüfung.
UnauthorizedParticipant: Angegebener Benutzer ist nicht als Teilnehmer dieser Veranstaltung registriert.
UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen.
+UnauthorizedAllocationRegisterTime: Diese Zentralanmeldung erlaubt momentan keine Bewerbungen.
UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben.
UnauthorizedApplicationTime: Diese Bewerbung ist momentan nicht freigegeben.
UnauthorizedMaterialTime: Dieses Material ist momentan nicht freigegeben.
@@ -1014,6 +1016,7 @@ AuthTagLecturer: Nutzer ist Dozent
AuthTagCorrector: Nutzer ist Korrektor
AuthTagTutor: Nutzer ist Tutor
AuthTagTime: Zeitliche Einschränkungen sind erfüllt
+AuthTagStaffTime: Zeitliche Einschränkungen für Lehrbeteiligte sind erfüllt
AuthTagAllocationTime: Zeitliche Einschränkungen durch Zentralanmeldung sind erfüllt
AuthTagCourseRegistered: Nutzer ist Kursteilnehmer
AuthTagTutorialRegistered: Nutzer ist Tutoriumsteilnehmer
diff --git a/models/allocations b/models/allocations
index f7522696f..0fac2cfee 100644
--- a/models/allocations
+++ b/models/allocations
@@ -1,12 +1,10 @@
Allocation -- attributes with prefix staff- affect lecturers only, but are invisble to students
- name (CI Text)
- shorthand (CI Text) -- practical shorthand
+ name AllocationName
+ shorthand AllocationShorthand -- practical shorthand
term TermId
school SchoolId -- school that manages this central allocation, not necessarily school of courses
description Html Maybe -- description for prospective students
staffDescription Html Maybe -- description seen by prospective lecturers only
- linkExternal Text Maybe -- arbitrary user-defined url for external course page
- capacity Int Maybe -- number of allowed enrolements, if restricte
staffRegisterFrom UTCTime Maybe -- lectureres may register courses
staffRegisterTo UTCTime Maybe -- course registration stops
-- staffDeregisterUntil not needed: staff may make arbitrary changes until staffRegisterTo, always frozen afterwards
@@ -17,7 +15,6 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis
registerFrom UTCTime Maybe -- student applications allowed from a given day onwwards or prohibited
registerTo UTCTime Maybe -- student applications may be prohibited from a given date onwards
-- deregisterUntil not needed: students may withdraw applicants until registerTo, but never after. Also see overrideDeregister
- registerSecret Text Maybe -- student application maybe protected by a simple common passphrase
-- overrides
registerByStaffFrom UTCTime Maybe -- lecturers may directly enrol/disenrol students after a given date or prohibited
registerByStaffTo UTCTime Maybe
@@ -26,6 +23,7 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis
-- overrideVisible not needed, since courses are always visible
TermSchoolAllocationShort term school shorthand -- shorthand must be unique within school and semester
TermSchoolAllocationName term school name -- name must be unique within school and semester
+ deriving Show
AllocationCourse
allocation AllocationId
@@ -41,7 +39,6 @@ AllocationUser
AllocationDeregister -- self-inflicted user-deregistrations from an allocated course
user UserId
- allocation AllocationId Maybe
course CourseId Maybe
time UTCTime
reason Text Maybe -- if this deregistration was done by proxy (e.g. the lecturer pressed the button)
diff --git a/routes b/routes
index 54f0fc5c5..d8cbe8260 100644
--- a/routes
+++ b/routes
@@ -80,6 +80,11 @@
/school SchoolListR GET !development
/school/#SchoolId SchoolShowR GET !development
+/allocation/#TermId/#SchoolId/#AllocationShorthand AllocationR:
+ / AShowR GET !free
+ /course/#CryptoUUIDCourse/apply AApplyR POST !time
+ /application/#CryptoFileNameCourseApplication AEditR GET POST !timeANDself !lecturerANDstaff-time
+
-- For Pattern Synonyms see Foundation
/course/ CourseListR GET !free
@@ -154,6 +159,7 @@
/users/new EAddUserR GET POST
/users/invite EInviteR GET POST
/register ERegisterR POST !timeANDcourse-registeredAND¬exam-registered !timeANDexam-registeredAND¬exam-result
+ /apps CApplicationsR GET POST
/apps/#CryptoFileNameCourseApplication CourseApplicationR:
/files CAFilesR GET !self !lecturerANDtime
diff --git a/src/Application.hs b/src/Application.hs
index 7291fda1c..597a316fd 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -112,6 +112,7 @@ import Handler.CryptoIDDispatch
import Handler.SystemMessage
import Handler.Health
import Handler.Exam
+import Handler.Allocation
-- This line actually creates our YesodDispatch instance. It is the second half
diff --git a/src/CryptoID.hs b/src/CryptoID.hs
index 915ad5de0..9263ca308 100644
--- a/src/CryptoID.hs
+++ b/src/CryptoID.hs
@@ -49,6 +49,7 @@ decCryptoIDs [ ''SubmissionId
, ''ExamPartId
, ''AllocationId
, ''CourseApplicationId
+ , ''CourseId
]
-- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission"
diff --git a/src/Data/CryptoID/Instances.hs b/src/Data/CryptoID/Instances.hs
index 3e842dd6a..bc66cb874 100644
--- a/src/Data/CryptoID/Instances.hs
+++ b/src/Data/CryptoID/Instances.hs
@@ -13,8 +13,24 @@ import ClassyPrelude
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
-instance {-# OVERLAPS #-} ToMarkup s => ToMarkup (CID.CryptoID c (CI s)) where
- toMarkup = toMarkup . CI.foldedCase . CID.ciphertext
+import Web.PathPieces
+import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..))
+
instance ToMarkup s => ToMarkup (CID.CryptoID c s) where
toMarkup = toMarkup . CID.ciphertext
+
+instance {-# OVERLAPS #-} ToMarkup s => ToMarkup (CID.CryptoID c (CI s)) where
+ toMarkup = toMarkup . CI.foldedCase . CID.ciphertext
+
+instance {-# OVERLAPS #-} ToJSON s => ToJSON (CID.CryptoID c (CI s)) where
+ toJSON = toJSON . CI.foldedCase . CID.ciphertext
+
+instance {-# OVERLAPS #-} (ToJSON s, ToJSONKey s) => ToJSONKey (CID.CryptoID c (CI s)) where
+ toJSONKey = case toJSONKey of
+ ToJSONKeyText toT toE -> ToJSONKeyText (toT . CI.foldedCase . CID.ciphertext) (toE . CI.foldedCase . CID.ciphertext)
+ ToJSONKeyValue toV toE -> ToJSONKeyValue (toV . CI.foldedCase . CID.ciphertext) (toE . CI.foldedCase . CID.ciphertext)
+
+instance {-# OVERLAPS #-} (PathPiece s, CI.FoldCase s) => PathPiece (CID.CryptoID c (CI s)) where
+ toPathPiece = toPathPiece . CI.foldedCase . CID.ciphertext
+ fromPathPiece = fmap (CID.CryptoID . CI.mk) . fromPathPiece
diff --git a/src/Data/Void/Instances.hs b/src/Data/Void/Instances.hs
new file mode 100644
index 000000000..a59e0cd39
--- /dev/null
+++ b/src/Data/Void/Instances.hs
@@ -0,0 +1,12 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Data.Void.Instances
+ (
+ ) where
+
+import ClassyPrelude.Yesod
+import Data.Void
+
+instance ToContent Void where
+ toContent = absurd
+instance ToTypedContent Void where
+ toTypedContent = absurd
diff --git a/src/Foundation.hs b/src/Foundation.hs
index d1e2e9892..3cfa94442 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -600,6 +600,17 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
E.&&. course E.^. CourseShorthand E.==. E.val csh
guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
return Authorized
+ -- Allocations: access only to school admins
+ AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do
+ authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+ isAdmin <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` userAdmin) -> do
+ E.on $ allocation E.^. AllocationSchool E.==. userAdmin E.^. UserAdminSchool
+ E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId
+ E.&&. allocation E.^. AllocationTerm E.==. E.val tid
+ E.&&. allocation E.^. AllocationSchool E.==. E.val ssh
+ E.&&. allocation E.^. AllocationShorthand E.==. E.val ash
+ guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
+ return Authorized
-- other routes: access to any admin is granted here
_other -> $cachedHereBinary mAuthId . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
@@ -641,6 +652,34 @@ tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of
E.&&. course E.^. CourseShorthand E.==. E.val csh
guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer)
return Authorized
+ AllocationR tid ssh ash (AEditR cID) -> $cachedHereBinary (mAuthId, tid, ssh, ash, cID) . exceptT return return $ do
+ authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+ appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedLecturer) (const True :: CryptoIDError -> Bool) $ decrypt cID
+ isLecturer <- lift . E.selectExists . E.from $ \(courseApplication `E.InnerJoin` allocation `E.InnerJoin` allocationCourse `E.InnerJoin` course `E.InnerJoin` lecturer) -> do
+ E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
+ E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse
+ E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation
+ E.on $ courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocation E.^. AllocationId)
+ E.&&. courseApplication E.^. CourseApplicationCourse E.==. course E.^. CourseId
+ E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
+ E.&&. allocation E.^. AllocationTerm E.==. E.val tid
+ E.&&. allocation E.^. AllocationSchool E.==. E.val ssh
+ E.&&. allocation E.^. AllocationShorthand E.==. E.val ash
+ E.&&. courseApplication E.^. CourseApplicationId E.==. E.val appId
+ guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer)
+ return Authorized
+ AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do
+ authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+ isLecturer <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` allocationCourse `E.InnerJoin` course `E.InnerJoin` lecturer) -> do
+ E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
+ E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse
+ E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation
+ E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
+ E.&&. allocation E.^. AllocationTerm E.==. E.val tid
+ E.&&. allocation E.^. AllocationSchool E.==. E.val ssh
+ E.&&. allocation E.^. AllocationShorthand E.==. E.val ash
+ guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedAllocationLecturer)
+ return Authorized
-- lecturer for any school will do
_ -> $cachedHereBinary mAuthId . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
@@ -712,8 +751,6 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
return Authorized
-
-
CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn
@@ -823,8 +860,16 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
return Authorized
_other -> unauthorizedI MsgUnauthorizedCourseTime
+ AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do
+ -- Checks `registerFrom` and `registerTo`, override as further routes become available
+ now <- liftIO getCurrentTime
+ Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash
+ guard $ NTop allocationRegisterFrom <= NTop (Just now)
+ guard $ NTop (Just now) <= NTop allocationRegisterTo
+ return Authorized
+
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
- smId <- decrypt cID
+ smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId
cTime <- (NTop . Just) <$> liftIO getCurrentTime
guard $ NTop systemMessageFrom <= cTime
@@ -832,6 +877,16 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
return Authorized
r -> $unsupportedAuthPredicate AuthTime r
+tagAccessPredicate AuthStaffTime = APDB $ \_ route _ -> case route of
+ AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do
+ -- Checks `registerFrom` and `registerTo`, override as further routes become available
+ now <- liftIO getCurrentTime
+ Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash
+ guard $ NTop allocationStaffAllocationFrom <= NTop (Just now)
+ guard $ NTop (Just now) <= NTop allocationStaffAllocationTo
+ return Authorized
+
+ r -> $unsupportedAuthPredicate AuthStaffTime r
tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of
CourseR tid ssh csh CRegisterR -> do
now <- liftIO getCurrentTime
@@ -974,7 +1029,7 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
let authorizedIfExists f = do
[E.Value ok] <- lift . E.select . return . E.exists $ E.from f
whenExceptT ok Authorized
- participant <- decrypt cID
+ participant <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedParticipant) (const True :: CryptoIDError -> Bool) $ decrypt cID
-- participant is currently registered
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
@@ -1030,6 +1085,13 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
+ -- participant is applicant for this course
+ $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseApplication) -> do
+ E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
+ E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val participant
+ E.&&. course E.^. CourseTerm E.==. E.val tid
+ E.&&. course E.^. CourseSchool E.==. E.val ssh
+ E.&&. course E.^. CourseShorthand E.==. E.val csh
unauthorizedI MsgUnauthorizedParticipant
r -> $unsupportedAuthPredicate AuthParticipant r
tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of
@@ -1105,20 +1167,21 @@ tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of
return Authorized
r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r
tagAccessPredicate AuthSelf = APDB $ \mAuthId route _ -> exceptT return return $ do
- referencedUser <- case route of
- AdminUserR cID -> decrypt cID
- AdminUserDeleteR cID -> decrypt cID
- AdminHijackUserR cID -> decrypt cID
- UserNotificationR cID -> decrypt cID
- UserPasswordR cID -> decrypt cID
- CourseR _ _ _ (CUserR cID) -> decrypt cID
+ referencedUser' <- case route of
+ AdminUserR cID -> return $ Left cID
+ AdminUserDeleteR cID -> return $ Left cID
+ AdminHijackUserR cID -> return $ Left cID
+ UserNotificationR cID -> return $ Left cID
+ UserPasswordR cID -> return $ Left cID
+ CourseR _ _ _ (CUserR cID) -> return $ Left cID
CApplicationR _ _ _ cID _ -> do
- appId <- decrypt cID
- application <- $cachedHereBinary appId . lift $ get appId
- case application of
- Nothing -> throwError =<< unauthorizedI MsgUnauthorizedSelf
- Just CourseApplication{..} -> return courseApplicationUser
+ appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID
+ CourseApplication{..} <- maybeMExceptT (unauthorizedI MsgUnauthorizedSelf) . $cachedHereBinary appId $ get appId
+ return $ Right courseApplicationUser
_other -> throwError =<< $unsupportedAuthPredicate AuthSelf route
+ referencedUser <- case referencedUser' of
+ Right uid -> return uid
+ Left cID -> catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID
case mAuthId of
Just uid
| uid == referencedUser -> return Authorized
@@ -1133,7 +1196,7 @@ tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do
UserPasswordR cID -> return cID
CourseR _ _ _ (CUserR cID) -> return cID
_other -> throwError =<< $unsupportedAuthPredicate AuthIsLDAP route
- referencedUser' <- decrypt referencedUser
+ referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser
maybeTMExceptT (unauthorizedI MsgUnauthorizedLDAP) $ do
User{..} <- MaybeT $ get referencedUser'
guard $ userAuthentication == AuthLDAP
@@ -1147,14 +1210,14 @@ tagAccessPredicate AuthIsPWHash = APDB $ \_ route _ -> exceptT return return $ d
UserPasswordR cID -> return cID
CourseR _ _ _ (CUserR cID) -> return cID
_other -> throwError =<< $unsupportedAuthPredicate AuthIsPWHash route
- referencedUser' <- decrypt referencedUser
+ referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser
maybeTMExceptT (unauthorizedI MsgUnauthorizedPWHash) $ do
User{..} <- MaybeT $ get referencedUser'
guard $ is _AuthPWHash userAuthentication
return Authorized
tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
- smId <- decrypt cID
+ smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId
let isAuthenticated = isJust mAuthId
guard $ not systemMessageAuthenticatedOnly || isAuthenticated
@@ -1659,6 +1722,12 @@ instance YesodBreadcrumbs UniWorX where
breadcrumb (TermSchoolCourseListR tid ssh) = return (original $ unSchoolKey ssh, Just $ TermCourseListR tid)
+ breadcrumb (AllocationR tid ssh ash AShowR) = do
+ mr <- getMessageRender
+ Entity _ Allocation{allocationName} <- runDB . getBy404 $ TermSchoolAllocationShort tid ssh ash
+ return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{original (unSchoolKey ssh)})|], Just $ HomeR)
+ breadcrumb (AllocationR tid ssh ash (AEditR _)) = return ("Bewerbung", Just $ AllocationR tid ssh ash AShowR)
+
breadcrumb CourseListR = return ("Kurse" , Nothing)
breadcrumb CourseNewR = return ("Neu" , Just CourseListR)
breadcrumb (CourseR tid ssh csh CShowR) = return (original csh, Just $ TermSchoolCourseListR tid ssh)
diff --git a/src/Handler/Allocation.hs b/src/Handler/Allocation.hs
new file mode 100644
index 000000000..bed822b0d
--- /dev/null
+++ b/src/Handler/Allocation.hs
@@ -0,0 +1,6 @@
+module Handler.Allocation
+ ( module Handler.Allocation
+ ) where
+
+import Handler.Allocation.Show as Handler.Allocation
+import Handler.Allocation.Edit as Handler.Allocation
diff --git a/src/Handler/Allocation/Edit.hs b/src/Handler/Allocation/Edit.hs
new file mode 100644
index 000000000..d9362babb
--- /dev/null
+++ b/src/Handler/Allocation/Edit.hs
@@ -0,0 +1,13 @@
+module Handler.Allocation.Edit
+ ( postAApplyR
+ , getAEditR, postAEditR
+ ) where
+
+import Import
+
+postAApplyR :: TermId -> SchoolId -> AllocationShorthand -> CryptoUUIDCourse -> Handler Void
+postAApplyR = fail "Not implemented"
+
+getAEditR, postAEditR :: TermId -> SchoolId -> AllocationShorthand -> CryptoFileNameCourseApplication -> Handler Void
+getAEditR = postAEditR
+postAEditR = fail "Not implemented"
diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs
new file mode 100644
index 000000000..71f1f3967
--- /dev/null
+++ b/src/Handler/Allocation/Show.hs
@@ -0,0 +1,15 @@
+module Handler.Allocation.Show
+ ( getAShowR
+ ) where
+
+import Import
+
+getAShowR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
+getAShowR tid ssh ash = do
+ Entity _ alloc <- runDB . getBy404 $ TermSchoolAllocationShort tid ssh ash
+
+ defaultLayout $ -- TODO
+ [whamlet|
+
+ #{tshow alloc}
+ |]
diff --git a/src/Handler/Course/Application.hs b/src/Handler/Course/Application.hs
index 17fa5127b..f4a1fcada 100644
--- a/src/Handler/Course/Application.hs
+++ b/src/Handler/Course/Application.hs
@@ -1,5 +1,6 @@
module Handler.Course.Application
( getCAFilesR
+ , getCApplicationsR, postCApplicationsR
) where
import Import
@@ -24,6 +25,10 @@ getCAFilesR tid ssh csh cID = do
, ssh == courseSchool
, csh == courseShorthand
]
+ forM_ courseApplicationAllocation $ \aId -> do
+ Allocation{..} <- get404 aId
+ cCourse <- encrypt courseApplicationCourse :: DB CryptoUUIDCourse
+ redirectWith movedPermanently301 $ AllocationR courseTerm courseSchool allocationShorthand AShowR :#: toPathPiece cCourse
unless matches . redirectWith movedPermanently301 $ CApplicationR courseTerm courseSchool courseShorthand cID CAFilesR
get404 courseApplicationUser
@@ -35,3 +40,7 @@ getCAFilesR tid ssh csh cID = do
return file
serveSomeFiles archiveName $ fsSource .| C.map entityVal
+
+getCApplicationsR, postCApplicationsR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCApplicationsR = postCApplicationsR
+postCApplicationsR = fail "not implemented" -- dbtable of _all_ course applications
diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs
index 36a82ac97..0d42bba87 100644
--- a/src/Handler/Course/Register.hs
+++ b/src/Handler/Course/Register.hs
@@ -218,8 +218,14 @@ postCRegisterR tid ssh csh = do
Just _ -> addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
BtnCourseDeregister -> runDB $ do
deleteApplications
- deleteBy $ UniqueParticipant uid cid
- audit $ TransactionCourseParticipantDeleted cid uid
+ part <- getBy $ UniqueParticipant uid cid
+ forM_ part $ \(Entity partId CourseParticipant{..}) -> do
+ delete $ partId
+ audit $ TransactionCourseParticipantDeleted cid uid
+
+ when courseParticipantAllocated $ do
+ now <- liftIO getCurrentTime
+ insert_ $ AllocationDeregister courseParticipantUser (Just courseParticipantCourse) now Nothing
examRegistrations <- E.select . E.from $ \(examRegistration `E.InnerJoin` exam) -> do
E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs
index 0eca71463..9bc1b8f53 100644
--- a/src/Handler/Course/Show.hs
+++ b/src/Handler/Course/Show.hs
@@ -79,6 +79,10 @@ getCShowR tid ssh csh = do
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration
+ cID <- encrypt cid :: Handler CryptoUUIDCourse
+ mAllocation' <- for mAllocation $ \Allocation{..} -> (,)
+ <$> pure allocationName
+ <*> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID)
regForm <- if
| is _Just mbAid -> do
(courseRegisterForm', regButton) <- courseRegisterForm (Entity cid course)
diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs
index 7ec441d58..e9d357662 100644
--- a/src/Import/NoModel.hs
+++ b/src/Import/NoModel.hs
@@ -112,6 +112,7 @@ import Database.Persist.Types.Instances as Import ()
import Data.UUID.Instances as Import ()
import System.FilePath.Instances as Import ()
import Net.IP.Instances as Import ()
+import Data.Void.Instances as Import ()
import Control.Monad.Trans.RWS (RWST)
diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs
index 8ad57e8a4..1c9109490 100644
--- a/src/Model/Migration.hs
+++ b/src/Model/Migration.hs
@@ -445,6 +445,15 @@ customMigrations = Map.fromListWith (>>)
whenM (tableExists "allocation_application_file") $
tableDropEmpty "allocation_application_file"
)
+ , ( AppliedMigrationKey [migrationVersion|17.0.0|] [version|18.0.0|]
+ , do
+ whenM (tableExists "allocation") $ do
+ [executeQQ|ALTER TABLE allocation DROP COLUMN IF EXISTS capacity;|]
+ [executeQQ|ALTER TABLE allocation DROP COLUMN IF EXISTS link_external;|]
+ [executeQQ|ALTER TABLE allocation DROP COLUMN IF EXISTS register_secret;|]
+ whenM (tableExists "allocation_deregister") $ do
+ [executeQQ|ALTER TABLE allocation_deregister DROP COLUMN IF EXISTS allocation;|]
+ )
]
diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs
index 2d8e8b1d0..53ff47cce 100644
--- a/src/Model/Types/Common.hs
+++ b/src/Model/Types/Common.hs
@@ -13,26 +13,28 @@ import Import.NoModel
import qualified Yesod.Auth.Util.PasswordStore as PWStore
-type Count = Sum Integer
-type Points = Centi
+type Count = Sum Integer
+type Points = Centi
-type Email = Text
+type Email = Text
-type SchoolName = CI Text
-type SchoolShorthand = CI Text
-type CourseName = CI Text
-type CourseShorthand = CI Text
-type SheetName = CI Text
-type MaterialName = CI Text
-type UserEmail = CI Email
-type UserIdent = CI Text
-type TutorialName = CI Text
-type ExamName = CI Text
-type ExamPartName = CI Text
-type ExamOccurrenceName = CI Text
+type SchoolName = CI Text
+type SchoolShorthand = CI Text
+type CourseName = CI Text
+type CourseShorthand = CI Text
+type SheetName = CI Text
+type MaterialName = CI Text
+type UserEmail = CI Email
+type UserIdent = CI Text
+type TutorialName = CI Text
+type ExamName = CI Text
+type ExamPartName = CI Text
+type ExamOccurrenceName = CI Text
+type AllocationName = CI Text
+type AllocationShorthand = CI Text
-type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
-type InstanceId = UUID
-type ClusterId = UUID
-type TokenId = UUID
-type TermCandidateIncidence = UUID
+type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
+type InstanceId = UUID
+type ClusterId = UUID
+type TokenId = UUID
+type TermCandidateIncidence = UUID
diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs
index c18083055..5503f9877 100644
--- a/src/Model/Types/Security.hs
+++ b/src/Model/Types/Security.hs
@@ -48,6 +48,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
| AuthExamResult
| AuthParticipant
| AuthTime
+ | AuthStaffTime
| AuthAllocationTime
| AuthMaterials
| AuthOwner
diff --git a/templates/course.hamlet b/templates/course.hamlet
index 713f61e13..1372fd58d 100644
--- a/templates/course.hamlet
+++ b/templates/course.hamlet
@@ -64,9 +64,11 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
#{participants}
$maybe capacity <- courseCapacity course
\ von #{capacity}
- $maybe Allocation{allocationName} <- mAllocation
+ $maybe (name, url) <- mAllocation'
_{MsgCourseAllocation}
- #{allocationName}
+
+
+ #{name}
$nothing
$maybe regFrom <- mRegFrom
Anmeldezeitraum
diff --git a/test/Database.hs b/test/Database.hs
index ab0d96b90..f90167b21 100755
--- a/test/Database.hs
+++ b/test/Database.hs
@@ -703,3 +703,25 @@ fillDb = do
void . insert $ SystemMessage (Just now) Nothing False Info "de" "System-Nachrichten können längeren Inhalt enthalten" (Just "System-Nachricht Zusammenfassung")
void . insert $ SystemMessage (Just now) (Just now) False Info "de" "System-Nachrichten haben Ablaufdaten" Nothing
void . insert $ SystemMessage Nothing Nothing False Error "de" "System-Nachrichten können Inaktiv sein" Nothing
+
+
+ funAlloc <- insert' Allocation
+ { allocationName = "Funktionale Zentralanmeldung"
+ , allocationShorthand = "fun"
+ , allocationTerm = TermKey summer2018
+ , allocationSchool = ifi
+ , allocationDescription = Nothing
+ , allocationStaffDescription = Nothing
+ , allocationStaffRegisterFrom = Just now
+ , allocationStaffRegisterTo = Nothing
+ , allocationStaffAllocationFrom = Nothing
+ , allocationStaffAllocationTo = Nothing
+ , allocationRegisterFrom = Nothing
+ , allocationRegisterTo = Nothing
+ , allocationRegisterByStaffFrom = Nothing
+ , allocationRegisterByStaffTo = Nothing
+ , allocationRegisterByCourse = Nothing
+ , allocationOverrideDeregister = Just now
+ }
+ insert_ $ AllocationCourse funAlloc pmo 100
+ insert_ $ AllocationCourse funAlloc ffp 2