feat(allocations): set up routes

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

models/allocations

@@ -1,12 +1,10 @@
 Allocation -- attributes with prefix staff- affect lecturers only, but are invisble to students
-    name                (CI Text)
+    name                AllocationName
-    shorthand           (CI Text)       -- practical shorthand
+    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)

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
 

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

src/CryptoID.hs

@@ -49,6 +49,7 @@ decCryptoIDs [ ''SubmissionId
              , ''ExamPartId
              , ''AllocationId
              , ''CourseApplicationId
+             , ''CourseId
              ]
 
 -- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission"

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
+import Web.PathPieces
-  toMarkup = toMarkup . CI.foldedCase . CID.ciphertext
+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

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

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
+  referencedUser' <- case route of
-    AdminUserR cID -> decrypt cID
+    AdminUserR cID -> return $ Left cID
-    AdminUserDeleteR cID -> decrypt cID
+    AdminUserDeleteR cID -> return $ Left cID
-    AdminHijackUserR cID -> decrypt cID
+    AdminHijackUserR cID -> return $ Left cID
-    UserNotificationR cID -> decrypt cID
+    UserNotificationR cID -> return $ Left cID
-    UserPasswordR cID -> decrypt cID
+    UserPasswordR cID -> return $ Left cID
-    CourseR _ _ _ (CUserR cID) -> decrypt cID
+    CourseR _ _ _ (CUserR cID) -> return $ Left cID
     CApplicationR _ _ _ cID _ -> do
-      appId <- decrypt cID
+      appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID
-      application <- $cachedHereBinary appId . lift $ get appId
+      CourseApplication{..} <- maybeMExceptT (unauthorizedI MsgUnauthorizedSelf) . $cachedHereBinary appId $ get appId
-      case application of
+      return $ Right courseApplicationUser
-        Nothing -> throwError =<< unauthorizedI MsgUnauthorizedSelf
-        Just CourseApplication{..} -> return 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)

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

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"

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|
+      <pre>
+        #{tshow alloc}
+    |]

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

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
+        part <- getBy $ UniqueParticipant uid cid
-        audit $ TransactionCourseParticipantDeleted cid uid
+        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

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)

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)

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;|]
+    )
   ]
 
 

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 Count                   = Sum Integer
-type Points = Centi
+type Points                  = Centi
 
-type Email              = Text
+type Email                   = Text
 
-type SchoolName         = CI Text
+type SchoolName              = CI Text
-type SchoolShorthand    = CI Text
+type SchoolShorthand         = CI Text
-type CourseName         = CI Text
+type CourseName              = CI Text
-type CourseShorthand    = CI Text
+type CourseShorthand         = CI Text
-type SheetName          = CI Text
+type SheetName               = CI Text
-type MaterialName       = CI Text
+type MaterialName            = CI Text
-type UserEmail          = CI Email
+type UserEmail               = CI Email
-type UserIdent          = CI Text
+type UserIdent               = CI Text
-type TutorialName       = CI Text
+type TutorialName            = CI Text
-type ExamName           = CI Text
+type ExamName                = CI Text
-type ExamPartName       = CI Text
+type ExamPartName            = CI Text
-type ExamOccurrenceName = CI Text
+type ExamOccurrenceName      = CI Text
+type AllocationName          = CI Text
+type AllocationShorthand     = CI Text
 
-type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
+type PWHashAlgorithm         = ByteString -> PWStore.Salt -> Int -> ByteString
-type InstanceId      = UUID
+type InstanceId              = UUID
-type ClusterId       = UUID
+type ClusterId               = UUID
-type TokenId         = UUID
+type TokenId                 = UUID
-type TermCandidateIncidence = UUID
+type TermCandidateIncidence  = UUID

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

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'
     <dt .deflist__dt>_{MsgCourseAllocation}
-    <dd .deflist__dd>#{allocationName}
+    <dd .deflist__dd>
+      <a href=#{url}>
+        #{name}
   $nothing
     $maybe regFrom <- mRegFrom
       <dt .deflist__dt>Anmeldezeitraum

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