feat(allocations): implement application interface

frontend/src/utils/inputs/inputs.scss

@@ -9,11 +9,9 @@
   grid-gap: 5px;
   justify-content: flex-start;
   align-items: flex-start;
-  padding: 4px 0;
-  border-left: 2px solid transparent;
 
-  + .form-group {
+  + .form-group, + .form-section-legend, + .form-section-notification {
-    margin-top: 7px;
+    margin-top: 11px;
   }
 
   + .form-section-title {

messages/uniworx/de.msg

@@ -170,6 +170,18 @@ CourseApplicationInstructionsRegistration: Anweisungen zur Anmeldung
 CourseApplicationTemplateApplication: Bewerbungsvorlage(n)
 CourseApplicationTemplateRegistration: Anmeldungsvorlage(n)
 CourseApplicationTemplateArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-bewerbungsvorlagen
+CourseApplication: Bewerbung
+
+CourseApplicationExists: Sie haben sich bereits für diesen Kurs beworben
+CourseApplicationInvalidAction: Angegeben Aktion kann nicht durchgeführt werden
+CourseApplicationCreated csh@CourseShorthand: Erfolgreich zu #{csh} beworben
+CourseApplicationEdited csh@CourseShorthand: Bewerbung zu #{csh} erfolgreich angepasst
+CourseApplicationNotEdited csh@CourseShorthand: Bewerbung zu #{csh} hat sich nicht verändert
+CourseApplicationRated: Bewertung erfolgreich angepasst
+CourseApplicationRatingDeleted: Bewertung erfolgreich entfernt
+CourseApplicationDeleted csh@CourseShorthand: Bewerbung zu #{csh} erfolgreich zurückgezogen
+
+CourseApplicationTitle displayName@Text csh@CourseShorthand: Bewerbung für #{csh}: #{displayName} 
 
 CourseApplicationText: Text-Bewerbung
 CourseApplicationFollowInstructions: Beachten Sie die Anweisungen zur Bewerbung!
@@ -183,6 +195,8 @@ CourseRegistrationFile: Datei zur Anmeldung
 CourseRegistrationFiles: Datei(en) zur Anmeldung
 CourseRegistrationArchive: Zip-Archiv der Datei(en) zur Anmeldung
 CourseApplicationNoFiles: Keine Datei(en)
+CourseApplicationFilesNeedReupload: Bewerbungsdateien müssen neu hochgeladen werden, wann immer die Bewerbung angepasst wird
+CourseRegistrationFilesNeedReupload: Dateien zur Anmeldung müssen neu hochgeladen werden, wann immer die Anmeldung angepasst wird
 
 CourseApplicationDeleteToEdit: Um Ihre Bewerbung zu editieren müssen Sie sie zunächst zurückziehen und sich erneut bewerben.
 CourseRegistrationDeleteToEdit: Um Ihre Anmeldungsdaten zu editieren müssen Sie sich zunächst ab- und dann erneut anmelden.
@@ -372,7 +386,7 @@ MaterialFree: Kursmaterialien ohne Anmeldung zugänglich
 UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung
 UnauthorizedSystemMessageTime: Diese Systemnachricht ist noch nicht oder nicht mehr einsehbar.
 UnauthorizedSystemMessageAuth: Diese Systemnachricht ist nur für angemeldete Benutzer einsehbar.
-UnsupportedAuthPredicate authTagT@Text shownRoute@String: "#{authTagT}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute}
+UnsupportedAuthPredicate authTagT@Text shownRoute@Text: „#{authTagT}“ wurde auf eine Route angewandt, die dies nicht unterstützt: „#{shownRoute}“
 UnauthorizedDisabledTag authTag@AuthTag: Authorisierungsprädikat "#{toPathPiece authTag}" ist für Ihre Sitzung nicht aktiv
 UnknownAuthPredicate tag@String: Authorisierungsprädikat "#{tag}" ist dem System nicht bekannt
 UnauthorizedRedirect: Die angeforderte Seite existiert nicht oder Sie haben keine Berechtigung, die angeforderte Seite zu sehen.
@@ -1472,6 +1486,7 @@ AllocationRegistrationEdited: Einstellungen zur Teilnahme an der Zentralanmeldun
 BtnAllocationRegister: Teilnahme registrieren
 BtnAllocationRegistrationEdit: Teilnahme anpassen
 AllocationParticipation: Teilnahme an der Zentralanmeldung
+AllocationParticipationLoginFirst: Um an der Zentralanmeldung teilzunehmen, loggen Sie sich bitte zunächst ein.
 AllocationCourses: Kurse
 AllocationData: Organisatorisches
 AllocationCoursePriority i@Natural: #{i}. Wahl

src/Crypto/Hash/Instances.hs

@@ -0,0 +1,22 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Crypto.Hash.Instances
+  () where
+
+import ClassyPrelude
+
+import Crypto.Hash
+
+import Database.Persist
+import Database.Persist.Sql
+
+import Data.ByteArray (convert)
+
+
+instance HashAlgorithm hash => PersistField (Digest hash) where
+  toPersistValue = PersistByteString . convert
+  fromPersistValue (PersistByteString bs) = maybe (Left "Could not convert Digest from ByteString") Right $ digestFromByteString bs
+  fromPersistValue _ = Left "Digest values must be converted from PersistByteString"
+
+instance HashAlgorithm hash => PersistFieldSql (Digest hash) where
+  sqlType _ = SqlBlob 

src/Database/Esqueleto/Utils.hs

@@ -15,10 +15,13 @@ module Database.Esqueleto.Utils
   , orderByOrd, orderByEnum
   , lower, ciEq
   , selectExists
+  , SqlHashable
+  , sha256
+  , maybe
   ) where
 
 
-import ClassyPrelude.Yesod hiding (isInfixOf, any, all, or, and, isJust)
+import ClassyPrelude.Yesod hiding (isInfixOf, any, all, or, and, isJust, maybe)
 import Data.Universe
 import qualified Data.Set as Set
 import qualified Data.List as List
@@ -27,6 +30,11 @@ import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Internal.Sql as E
 import Database.Esqueleto.Utils.TH
 
+import qualified Data.Text.Lazy as Lazy (Text)
+import qualified Data.ByteString.Lazy as Lazy (ByteString)
+
+import Crypto.Hash (Digest, SHA256)
+
 {-# ANN any ("HLint: ignore Use any" :: String) #-}
 {-# ANN all ("HLint: ignore Use all" :: String) #-}
 
@@ -199,3 +207,28 @@ selectExists query = do
   case res of
     [E.Value b] -> return b
     _other      -> error "SELECT EXISTS ... returned zero or more than one rows"
+
+
+class SqlHashable a
+instance SqlHashable Text
+instance SqlHashable ByteString
+instance SqlHashable Lazy.Text
+instance SqlHashable Lazy.ByteString
+
+
+sha256 :: SqlHashable a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value (Digest SHA256))
+sha256 = E.unsafeSqlFunction "digest" . (, E.val "sha256" :: E.SqlExpr (E.Value Text))
+
+
+maybe :: (PersistField a, PersistField b)
+      => E.SqlExpr (E.Value b)
+      -> (E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b))
+      -> E.SqlExpr (E.Value (Maybe a))
+      -> E.SqlExpr (E.Value b)
+maybe onNothing onJust val = E.case_
+  [ E.when_
+      (E.not_ $ E.isNothing val)
+    E.then_
+      (onJust $ E.veryUnsafeCoerceSqlExprValue val)
+  ]
+  (E.else_ onNothing)

src/Foundation.hs

@@ -283,8 +283,12 @@ instance RenderMessage UniWorX MsgLanguage where
     where
       mr = renderMessage foundation ls
 
-instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where
+instance RenderMessage UniWorX (UnsupportedAuthPredicate AuthTag (Route UniWorX)) where
-  renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route)
+  renderMessage f ls (UnsupportedAuthPredicate tag route) = mr . MsgUnsupportedAuthPredicate (mr tag) $ Text.intercalate "/" pieces
+    where
+      mr :: forall msg. RenderMessage UniWorX msg => msg -> Text
+      mr = renderMessage f ls
+      (pieces, _) = renderRoute route
 
 embedRenderMessage ''UniWorX ''MessageStatus ("Message" <>)
 embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel
@@ -1189,6 +1193,10 @@ tagAccessPredicate AuthSelf = APDB $ \mAuthId route _ -> exceptT return return $
       appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID
       CourseApplication{..} <- maybeMExceptT (unauthorizedI MsgUnauthorizedSelf) . $cachedHereBinary appId $ get appId
       return $ Right courseApplicationUser
+    AllocationR _ _ _ (AApplicationR cID) -> do
+      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

src/Handler/Admin.hs

@@ -21,7 +21,7 @@ import qualified Data.Map as Map
 
 import Database.Persist.Sql (fromSqlKey)
 import qualified Database.Esqueleto as E
-import Database.Esqueleto.Utils as E
+import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter)
 
 import Handler.Utils.Table.Cells
 import qualified Handler.Utils.TermCandidates as Candidates

src/Handler/Allocation/Application.hs

@@ -9,12 +9,23 @@ module Handler.Allocation.Application
   , getAApplicationR, postAApplicationR
   ) where
 
-import Import
+import Import hiding (hash)
 
 import Handler.Utils
 import Utils.Lens
 
 import qualified Data.Text as Text
+import qualified Data.Set as Set
+
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+
+import qualified Data.Conduit.List as C
+
+import Crypto.Hash (hash)
+
+import Control.Monad.Trans.State (execStateT)
+import Control.Monad.State.Class (modify) 
 
 
 data AllocationApplicationButton = BtnAllocationApply
@@ -27,6 +38,7 @@ instance Finite AllocationApplicationButton
 
 nullaryPathPiece ''AllocationApplicationButton $ camelToPathPiece' 1
 embedRenderMessage ''UniWorX ''AllocationApplicationButton id
+makePrisms ''AllocationApplicationButton
 
 instance Button UniWorX AllocationApplicationButton where
   btnClasses BtnAllocationApplicationRetract = [BCIsButton, BCDanger]
@@ -55,6 +67,7 @@ data ApplicationFormMode = ApplicationFormMode
   , afmApplicantEdit :: Bool -- ^ Allow editing text, files, priority (if shown)
   , afmLecturer      :: Bool -- ^ Allow editing rating
   }
+ 
 
 data ApplicationFormException = ApplicationFormNoApplication -- ^ Could not fill forced fields of application form with data from application
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
@@ -63,22 +76,27 @@ instance Exception ApplicationFormException
 applicationForm :: AllocationId
                 -> CourseId
                 -> UserId
-                -> Natural -- ^ Maximum @courseApplicationAllocationPriority@ among all applications
                 -> ApplicationFormMode -- ^ Which parts of the shared form to display
                 -> Html -> MForm Handler (FormResult ApplicationForm, ApplicationFormView)
-applicationForm aId cid uid maxPrio ApplicationFormMode{..} csrf = do
+applicationForm aId cid uid ApplicationFormMode{..} csrf = do
-  (mApp, coursesNum, Course{..}) <- liftHandlerT . runDB $ do
+  (mApp, coursesNum, Course{..}, maxPrio) <- liftHandlerT . runDB $ do
     mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. Just aId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1]
     coursesNum <- fromIntegral <$> count [AllocationCourseAllocation ==. aId]
     course <- getJust cid
-    return (mApplication, coursesNum, course)
+    [E.Value (fromMaybe 0 -> maxPrio)] <- E.select . E.from $ \courseApplication -> do
+      E.where_ $ courseApplication E.^. CourseApplicationCourse     E.==. E.val cid
+           E.&&. courseApplication E.^. CourseApplicationUser       E.==. E.val uid
+           E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (E.val aId)
+           E.&&. E.not_ (E.isNothing $ courseApplication E.^. CourseApplicationAllocationPriority)
+      return . E.joinV . E.max_ $ courseApplication E.^. CourseApplicationAllocationPriority
+    return (mApplication, coursesNum, course, maxPrio)
   MsgRenderer mr <- getMsgRenderer
 
   let
     oldPrio :: Maybe Natural
     oldPrio = mApp >>= courseApplicationAllocationPriority . entityVal
 
-    coursesNum' = succ maxPrio `max` pred coursesNum
+    coursesNum' = succ maxPrio `max` coursesNum
 
     mkPrioOption :: Natural -> Option Natural
     mkPrioOption i = Option
@@ -89,7 +107,7 @@ applicationForm aId cid uid maxPrio ApplicationFormMode{..} csrf = do
     
     prioOptions :: OptionList Natural
     prioOptions = OptionList
-      { olOptions = sortOn (Down . optionInternalValue) . map mkPrioOption $ [0 .. coursesNum']
+      { olOptions = sortOn (Down . optionInternalValue) . map mkPrioOption $ [0 .. pred coursesNum']
       , olReadExternal = readMay
       }
     prioField = selectField' (Just $ SomeMessage MsgAllocationCourseNoApplication) $ return prioOptions
@@ -153,6 +171,12 @@ applicationForm aId cid uid maxPrio ApplicationFormMode{..} csrf = do
     | otherwise
       -> return Nothing
 
+  filesWarningView <- if
+    | fromMaybe False hasFiles && isn't _NoUpload courseApplicationsFiles && afmApplicantEdit
+      -> fmap (Just . snd) . formMessage =<< messageIconI Info IconFileUpload MsgCourseApplicationFilesNeedReupload
+    | otherwise
+      -> return Nothing
+
   (filesRes, filesView) <-
     let mkFs = bool MsgCourseApplicationFile MsgCourseApplicationArchive
      in if
@@ -181,10 +205,10 @@ applicationForm aId cid uid maxPrio ApplicationFormMode{..} csrf = do
   
   let
     buttons = catMaybes
-      [ guardOn (not afmApplicantEdit && is _Just    mApp) BtnAllocationApplicationRate
+      [ guardOn (not afmApplicantEdit && is _Just    mApp && afmLecturer) BtnAllocationApplicationRate
-      , guardOn (    afmApplicantEdit && is _Just    mApp) BtnAllocationApplicationEdit
+      , guardOn (    afmApplicantEdit && is _Just    mApp               ) BtnAllocationApplicationEdit
-      , guardOn (    afmApplicantEdit && is _Nothing mApp) BtnAllocationApply
+      , guardOn (    afmApplicantEdit && is _Nothing mApp               ) BtnAllocationApply
-      , guardOn (    afmApplicantEdit && is _Just    mApp) BtnAllocationApplicationRetract
+      , guardOn (    afmApplicantEdit && is _Just    mApp               ) BtnAllocationApplicationRetract
       ]
   (actionRes, buttonsView) <- buttonForm' buttons csrf
 
@@ -203,6 +227,7 @@ applicationForm aId cid uid maxPrio ApplicationFormMode{..} csrf = do
              [ Just fieldView'
              , textView
              , filesLinkView
+             , filesWarningView
              ] ++ maybe [] (map Just) filesView ++
              [ vetoView
              , pointsView
@@ -215,9 +240,205 @@ applicationForm aId cid uid maxPrio ApplicationFormMode{..} csrf = do
  
 
 
-postAApplyR :: TermId -> SchoolId -> AllocationShorthand -> CryptoUUIDCourse -> Handler Void
+editApplicationR :: AllocationId
-postAApplyR = fail "Not implemented"
+                 -> UserId
+                 -> CourseId
+                 -> Maybe CourseApplicationId
+                 -> ApplicationFormMode
+                 -> (AllocationApplicationButton -> Bool)
+                 -> SomeRoute UniWorX
+                 -> Handler (ApplicationFormView, Enctype)
+editApplicationR aId uid cid mAppId afMode allowAction postAction = do
+  Course{..} <- runDB $ get404 cid
 
-getAApplicationR, postAApplicationR :: TermId -> SchoolId -> AllocationShorthand -> CryptoFileNameCourseApplication -> Handler Void
+  ((appRes, appView), appEnc) <- runFormPost $ applicationForm aId cid uid afMode
+
+  formResult appRes $ \ApplicationForm{..} -> do
+    if
+      | BtnAllocationApply <- afAction
+      , allowAction afAction
+        -> runDB $ do
+          haveOld <- exists [ CourseApplicationCourse     ==. cid
+                            , CourseApplicationUser       ==. uid
+                            , CourseApplicationAllocation ==. Just aId
+                            ]
+          when haveOld $
+            invalidArgsI [MsgCourseApplicationExists]
+
+          now <- liftIO getCurrentTime
+          let rated = afRatingVeto || is _Just afRatingPoints
+
+          appId <- insert CourseApplication
+            { courseApplicationCourse             = cid
+            , courseApplicationUser               = uid
+            , courseApplicationField              = afField
+            , courseApplicationText               = afText
+            , courseApplicationRatingVeto         = afRatingVeto
+            , courseApplicationRatingPoints       = afRatingPoints
+            , courseApplicationRatingComment      = afRatingComment
+            , courseApplicationAllocation         = Just aId
+            , courseApplicationAllocationPriority = afPriority
+            , courseApplicationTime               = now
+            , courseApplicationRatingTime         = guardOn rated now
+            }
+          let
+            sinkFile' file = do
+              fId <- insert file
+              insert_ $ CourseApplicationFile appId fId
+          forM_ afFiles $ \afFiles' ->
+            runConduit $ transPipe liftHandlerT afFiles' .| C.mapM_ sinkFile'
+          audit $ TransactionCourseApplicationEdit cid uid appId
+          addMessageI Success $ MsgCourseApplicationCreated courseShorthand
+      | is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction
+      , allowAction afAction
+      , Just appId <- mAppId
+        -> runDB $ do
+          now <- liftIO getCurrentTime
+
+          changes <- if
+            | afmApplicantEdit afMode -> do
+              oldFiles <- Set.fromList . map (courseApplicationFileFile . entityVal) <$> selectList [CourseApplicationFileApplication ==. appId] []
+              changes <- flip execStateT oldFiles . forM_ afFiles $ \afFiles' ->
+                let sinkFile' file = do
+                      oldFiles' <- lift . E.select . E.from $ \(courseApplicationFile `E.InnerJoin` file') -> do
+                        E.on $ courseApplicationFile E.^. CourseApplicationFileFile E.==. file' E.^. FileId
+                        E.where_ $ file' E.^. FileTitle E.==. E.val (fileTitle file)
+                                E.&&. E.maybe
+                                        (E.val . is _Nothing $ fileContent file)
+                                        (\fc' -> maybe E.false (\fc -> E.sha256 fc' E.==. E.val (hash fc)) $ fileContent file)
+                                        (file' E.^. FileContent)
+                                E.&&. file' E.^. FileId `E.in_` E.valList (Set.toList oldFiles)
+                        return $ file' E.^. FileId
+                      if
+                        | [E.Value oldFileId] <- oldFiles'
+                          -> modify $ Set.delete oldFileId
+                        | otherwise
+                          -> do
+                            fId <- lift $ insert file
+                            lift . insert_ $ CourseApplicationFile appId fId
+                            modify $ Set.insert fId
+                 in runConduit $ transPipe liftHandlerT afFiles' .| C.mapM_ sinkFile'
+              deleteCascadeWhere [ FileId <-. Set.toList (oldFiles `Set.intersection` changes) ]
+              return changes
+            | otherwise
+              -> return Set.empty
+
+          oldApp <- get404 appId
+          let newApp = oldApp
+                { courseApplicationField              = afField
+                , courseApplicationText               = afText
+                , courseApplicationRatingVeto         = afRatingVeto
+                , courseApplicationRatingPoints       = afRatingPoints
+                , courseApplicationRatingComment      = afRatingComment
+                , courseApplicationAllocation         = Just aId
+                , courseApplicationAllocationPriority = afPriority
+                }
+
+              newRating = any (\f -> f oldApp newApp)
+                [ (/=) `on` courseApplicationRatingVeto
+                , (/=) `on` courseApplicationRatingPoints
+                , (/=) `on` courseApplicationRatingComment
+                ]
+              hasRating = any ($ newApp)
+                [ courseApplicationRatingVeto
+                , is _Just . courseApplicationRatingPoints
+                ]
+
+              appChanged = any (\f -> f oldApp newApp)
+                [ (/=) `on` courseApplicationField
+                , (/=) `on` courseApplicationText
+                , \_ _ -> not $ Set.null changes
+                ]
+
+              newApp' = newApp
+                & bool id (set _courseApplicationRatingTime Nothing) appChanged
+                & bool id (set _courseApplicationRatingTime $ Just now) (newRating && hasRating)
+                & bool id (set _courseApplicationTime now) appChanged
+          replace appId newApp'
+          audit $ TransactionCourseApplicationEdit cid uid appId
+
+          uncurry addMessageI =<< case (afmLecturer afMode, newRating, hasRating, appChanged) of
+            (_, False, _, True) -> return (Success, MsgCourseApplicationEdited courseShorthand)
+            (_, False, _, False) -> return (Info, MsgCourseApplicationNotEdited courseShorthand)
+            (True, True, True, _) -> return (Success, MsgCourseApplicationRated)
+            (True, True, False, _) -> return (Success, MsgCourseApplicationRatingDeleted)
+            (False, True, _, _) -> permissionDenied "rating changed without lecturer rights"
+      | is _BtnAllocationApplicationRetract afAction
+      , allowAction afAction
+      , Just appId <- mAppId
+        -> runDB $ do
+          deleteCascade appId
+          audit $ TransactionCourseApplicationDeleted cid uid appId
+          addMessageI Success $ MsgCourseApplicationDeleted courseShorthand
+      | otherwise
+        -> invalidArgsI [MsgCourseApplicationInvalidAction]
+
+    redirect postAction
+
+  return (appView, appEnc)
+        
+
+postAApplyR :: TermId -> SchoolId -> AllocationShorthand -> CryptoUUIDCourse -> Handler Void
+postAApplyR tid ssh ash cID = do
+  uid <- requireAuthId
+  cid <- decrypt cID
+  (aId, Course{..}) <- runDB $ do
+    aId <- getKeyBy404 $ TermSchoolAllocationShort tid ssh ash
+    course <- get404 cid
+    return (aId, course)
+
+  afmLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
+
+  let afMode = ApplicationFormMode
+        { afmApplicant = True
+        , afmApplicantEdit = True
+        , afmLecturer
+        }
+
+  void . editApplicationR aId uid cid Nothing afMode (== BtnAllocationApply) . SomeRoute $ AllocationR tid ssh ash AShowR :#: cID
+
+  invalidArgs ["Application form required"]
+
+
+getAApplicationR, postAApplicationR :: TermId -> SchoolId -> AllocationShorthand -> CryptoFileNameCourseApplication -> Handler Html
 getAApplicationR = postAApplicationR
-postAApplicationR = fail "Not implemented"
+postAApplicationR tid ssh ash cID = do
+  uid <- requireAuthId
+  appId <- decrypt cID
+  (Entity aId Allocation{..}, Entity cid Course{..}, CourseApplication{..}, isAdmin, User{..}) <- runDB $ do
+    alloc <- getBy404 $ TermSchoolAllocationShort tid ssh ash
+    app <- get404 appId
+    Just course <- getEntity $ courseApplicationCourse app
+    Just appUser <- get $ courseApplicationUser app
+    isAdmin <- exists [UserAdminUser ==. uid, UserAdminSchool ==. alloc ^. _entityVal . _allocationSchool]
+    return (alloc, course, app, isAdmin, appUser)
+
+  afmLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
+  afmApplicantEdit <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplicationR cID
+  courseCID <- encrypt cid :: Handler CryptoUUIDCourse
+
+  let afMode = ApplicationFormMode
+        { afmApplicant = uid == courseApplicationUser || isAdmin
+        , afmApplicantEdit
+        , afmLecturer
+        }
+
+  (ApplicationFormView{..}, appEnc) <- editApplicationR aId uid cid (Just appId) afMode (/= BtnAllocationApply) $ if
+    | uid == courseApplicationUser
+      -> SomeRoute $ AllocationR tid ssh ash AShowR :#: courseCID
+    | otherwise
+      -> SomeRoute . AllocationR tid ssh ash $ AApplicationR cID
+
+  let title = MsgCourseApplicationTitle userDisplayName courseShorthand
+
+  siteLayoutMsg title $ do
+    setTitleI title
+
+    wrapForm ((<> snd afvButtons) . renderFieldViews FormStandard . maybe id (:) afvPriority$ afvForm) FormSettings
+      { formMethod = POST
+      , formAction = Just . SomeRoute . AllocationR tid ssh ash $ AApplicationR cID
+      , formEncoding = appEnc
+      , formAttrs = []
+      , formSubmit = FormNoSubmit
+      , formAnchor = Nothing :: Maybe Text
+      }

src/Handler/Allocation/Show.hs

@@ -60,8 +60,6 @@ getAShowR tid ssh ash = do
       , formSubmit = FormSubmit
       , formAnchor = Nothing :: Maybe Text
       }
-  let
-    maxPrio = maybe 0 maximum . fromNullable $ courses ^.. folded . resultCourseApplication . _entityVal . _courseApplicationAllocationPriority . _Just
 
   siteLayoutMsg title $ do
     setTitleI shortTitle
@@ -73,20 +71,26 @@ getAShowR tid ssh ash = do
           cID <- encrypt cid :: WidgetT UniWorX IO CryptoUUIDCourse
           mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID
           isLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
-          mApplyFormView <- liftHandlerT . for muid $ \uid -> generateFormPost . applicationForm aId cid uid maxPrio $ ApplicationFormMode True mayApply isLecturer
+          mApplyFormView <- liftHandlerT . for muid $ \uid -> generateFormPost . applicationForm aId cid uid $ ApplicationFormMode True mayApply isLecturer
           subRoute <- fmap (fromMaybe $ AApplyR cID) . for mApp $ \(Entity appId _) -> AApplicationR <$> encrypt appId
           let mApplyFormView' = view _1 <$> mApplyFormView
+              overrideVisible = not mayApply && is _Just mApp
           case mApplyFormView of
             Just (_, appFormEnctype)
               -> wrapForm $(widgetFile "allocation/show/course") FormSettings
                  { formMethod = POST
                  , formAction = Just . SomeRoute $ AllocationR tid ssh ash subRoute
                  , formEncoding = appFormEnctype
-                 , formAttrs = []
+                 , formAttrs = [ ("class", "allocation-course")
+                               ]
                  , formSubmit = FormNoSubmit
-                 , formAnchor = Nothing :: Maybe Text
+                 , formAnchor = Just cID
                  }
             Nothing
-              -> $(widgetFile "allocation/show/course")
+              -> let wdgt = $(widgetFile "allocation/show/course")
+                  in [whamlet|
+                       <div .allocation-course ##{toPathPiece cID}>
+                         ^{wdgt}
+                     |]
   
     $(widgetFile "allocation/show")

src/Handler/Course/Application.hs

@@ -25,10 +25,6 @@ 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
 

src/Handler/Course/Register.hs

@@ -114,26 +114,26 @@ courseRegisterForm (Entity cid Course{..}) = liftHandlerT $ do
     let appFilesInfo = (,) <$> hasFiles <*> appCID
         filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired
 
-    if
+    when (isn't _NoUpload courseApplicationsFiles || fromMaybe False hasFiles) $
-      | isn't _NoUpload courseApplicationsFiles || fromMaybe False hasFiles
+      let filesLinkField = Field{..}
-        -> let filesLinkField = Field{..}
+            where
-                 where
+              fieldParse _ _ = return $ Right Nothing
-                   fieldParse _ _ = return $ Right Nothing
+              fieldEnctype = mempty
-                   fieldEnctype = mempty
+              fieldView theId _ attrs _ _
-                   fieldView theId _ attrs _ _
+                = [whamlet|
-                     = [whamlet|
+                    $newline never
-                         $newline never
+                      $case appFilesInfo
-                           $case appFilesInfo
+                        $of Just (True, appCID)
-                             $of Just (True, appCID)
+                          <a ##{theId} *{attrs} href=@{CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR}>
-                               <a ##{theId} *{attrs} href=@{CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR}>
+                            _{filesMsg}
-                                 _{filesMsg}
+                        $of _
-                             $of _
+                          <span ##{theId} *{attrs}>
-                               <span ##{theId} *{attrs}>
+                            _{MsgCourseApplicationNoFiles}
-                                 _{MsgCourseApplicationNoFiles}
+                  |]
-                       |]
+       in void $ wforced filesLinkField (fslI filesMsg) Nothing
-            in void $ wforced filesLinkField (fslI filesMsg) Nothing
+
-      | otherwise
+    when (fromMaybe False hasFiles && isn't _NoUpload courseApplicationsFiles) $
-        -> return ()
+      wformMessage <=< messageIconI Info IconFileUpload $ bool MsgCourseRegistrationFilesNeedReupload MsgCourseApplicationFilesNeedReupload courseApplicationsRequired
 
     appFilesRes <- let mkFs | courseApplicationsRequired = bool MsgCourseApplicationFile MsgCourseApplicationArchive
                             | otherwise                  = bool MsgCourseRegistrationFile MsgCourseRegistrationArchive

src/Handler/Sheet.hs

@@ -726,7 +726,7 @@ correctorForm shid = wFormToAForm $ do
   -- when (not (Map.null loads) && applyDefaultLoads) $       -- Alert Message
   --   addMessageI Warning MsgCorrectorsDefaulted
   when (not (Map.null loads) && applyDefaultLoads) $          -- Alert Notification
-    wformMessage =<< messageI Warning MsgCorrectorsDefaulted
+    wformMessage =<< messageIconI Warning IconNoCorrectors MsgCorrectorsDefaulted
 
 
   let

src/Handler/Utils/Table/Columns.hs

@@ -12,7 +12,7 @@ import Import
 -- import Text.Blaze (ToMarkup(..))
 
 import qualified Database.Esqueleto as E
-import Database.Esqueleto.Utils as E
+import Database.Esqueleto.Utils (mkExactFilter, mkExactFilterWith, mkContainsFilter, mkContainsFilterWith, anyFilter)
 
 import Utils.Lens
 import Handler.Utils

src/Import/NoModel.hs

@@ -113,6 +113,7 @@ 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 Crypto.Hash.Instances as Import ()
 
 
 import Control.Monad.Trans.RWS (RWST)

src/Model/Migration.hs

@@ -127,7 +127,7 @@ requiresMigration = mapReaderT (exceptT return return) $ do
 initialMigration :: Migration
 -- ^ Manual migrations to go to InitialVersion below:
 initialMigration = do
-  migrateEnableExtension "citext"
+  mapM_ migrateEnableExtension ["citext", "pgcrypto"]
   migrateDBVersioning
 
 getMissingMigrations :: forall m m'.

src/Utils.hs

@@ -105,16 +105,17 @@ guardAuthResult AuthenticationRequired = notAuthenticated
 guardAuthResult (Unauthorized t) = permissionDenied t
 guardAuthResult Authorized = return ()
 
-data UnsupportedAuthPredicate route = UnsupportedAuthPredicate Text route
+data UnsupportedAuthPredicate tag route = UnsupportedAuthPredicate tag route
   deriving (Eq, Ord, Typeable, Show)
-instance (Show route, Typeable route) => Exception (UnsupportedAuthPredicate route)
+instance (Show tag, Typeable tag, Show route, Typeable route) => Exception (UnsupportedAuthPredicate tag route)
 
 unsupportedAuthPredicate :: ExpQ
 unsupportedAuthPredicate = do
   logFunc <- logErrorS
   [e| \tag route -> do
-        $(return logFunc) "AccessControl" [st|"!#{toPathPiece tag}" used on route that doesn't support it: #{tshow route}|]
+        tRoute <- toTextUrl route
-        unauthorizedI (UnsupportedAuthPredicate (toPathPiece tag) route)
+        $(return logFunc) "AccessControl" $ "!" <> toPathPiece tag <> " used on route that doesn't support it: " <> tRoute
+        unauthorizedI (UnsupportedAuthPredicate tag route)
     |]
 
 -- | allows conditional attributes in hamlet via *{..} syntax

src/Utils/DB.hs

@@ -48,6 +48,10 @@ existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity r
           => Key record -> ReaderT backend m Bool
 existsKey = fmap isJust . get -- TODO optimize, so that DB does not deliver entire record
 
+exists :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadIO m)
+       => [Filter record] -> ReaderT backend m Bool
+exists = fmap (not . null) . flip selectKeysList [LimitTo 1]
+
 updateBy :: (PersistUniqueRead backend, PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend )
          => Unique record -> [Update record] -> ReaderT backend m ()
 updateBy uniq updates = do

src/Utils/Form.hs

@@ -808,15 +808,26 @@ wformMessage :: (MonadHandler m) => Message -> WForm m ()
 wformMessage = void . aFormToWForm . aformMessage
 
 formMessage :: (MonadHandler m) => Message -> MForm m (FormResult (), FieldView site)
-formMessage Message{ messageIcon = _, ..} = do -- custom icons are not currently implemented for `.notification`
+formMessage Message{..} = do
   return (FormSuccess (), FieldView
     { fvLabel    = mempty
     , fvTooltip  = Nothing
     , fvId       = idFormMessageNoinput
     , fvErrors   = Nothing
     , fvRequired = False
-    , fvInput    = [whamlet|<div .notification .notification-#{toPathPiece messageStatus}>#{messageContent}|]
+    , fvInput    = [whamlet|
+                     $newline never
+                     <div .notification .notification-#{toPathPiece messageStatus} .fa-#{maybe defaultIcon iconText messageIcon}>
+                       <div .notification__content>
+                         #{messageContent}
+                   |]
     })
+  where
+    defaultIcon = case messageStatus of
+      Success -> "check-circle"
+      Info    -> "info-circle"
+      Warning -> "exclamation-circle"
+      Error   -> "exclamation-triangle"
 
 ---------------------
 -- Form evaluation --

src/Utils/Icon.hs

@@ -47,6 +47,7 @@ data Icon
   | IconCommentFalse
   | IconLink
   | IconFileDownload
+  | IconFileUpload
   | IconFileZip
   | IconFileCSV
   | IconSFTQuestion  -- for SheetFileType only
@@ -57,6 +58,7 @@ data Icon
   | IconRegisterTemplate
   | IconApplyTrue
   | IconApplyFalse
+  | IconNoCorrectors
   deriving (Eq, Ord, Enum, Bounded, Show, Read)
 
 iconText :: Icon -> Text
@@ -78,6 +80,7 @@ iconText = \case
     IconCommentFalse       -> "comment-slash"      -- comment-alt-slash is not available for free
     IconLink               -> "link"
     IconFileDownload       -> "file-download"
+    IconFileUpload         -> "file-upload"
     IconFileZip            -> "file-archive"
     IconFileCSV            -> "file-csv"
     IconSFTQuestion        -> "question-circle"    -- for SheetFileType only, should all be round (similar)
@@ -88,6 +91,7 @@ iconText = \case
     IconRegisterTemplate   -> "file-alt"
     IconApplyTrue          -> "file-alt"
     IconApplyFalse         -> "trash"
+    IconNoCorrectors       -> "user-slash"
 
 instance Universe Icon
 instance Finite   Icon

src/Utils/Lens.hs

@@ -155,6 +155,8 @@ makePrisms ''AuthenticationMode
 makeLenses_ ''CourseUserNote
 
 makeLenses_ ''CourseApplication
+  
+makeLenses_ ''Allocation
 
 
 -- makeClassy_ ''Load

src/Utils/Message.hs

@@ -6,6 +6,7 @@ module Utils.Message
   , addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget
   , statusToUrgencyClass
   , Message(..)
+  , messageIconI
   , messageI, messageIHamlet, messageFile, messageWidget
   ) where
 
@@ -140,6 +141,11 @@ messageI messageStatus msg = do
   let messageIcon = Nothing
   return Message{..}
 
+messageIconI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> Icon -> msg -> m Message
+messageIconI messageStatus (Just -> messageIcon) msg = do
+  messageContent <- toHtml . ($ msg) <$> getMessageRender
+  return Message{..}
+
 addMessageIHamlet :: ( MonadHandler m
                      , RenderMessage (HandlerSite m) msg
                      , HandlerSite m ~ site

templates/allocation/show.hamlet

@@ -34,28 +34,34 @@ $newline never
         <dd .deflist__dd>
           ^{formatTimeRangeW SelFormatDateTime fromT allocationStaffAllocationTo}
 
-$if mayRegister || is _Just registration
+$if is _Just muid
+  $if mayRegister || is _Just registration
+    <section id=allocation-participation>
+      <h2>
+        _{MsgAllocationParticipation}
+      $if mayRegister
+        ^{registerForm'}
+      $else
+        $maybe Entity _ AllocationUser{allocationUserTotalCourses} <- registration
+          <dl .deflist>
+            <dt .deflist__dt>
+              _{MsgAllocationTotalCourses}
+            <dd .deflist__dd>
+              #{allocationUserTotalCourses}
+$else
   <section id=allocation-participation>
     <h2>
       _{MsgAllocationParticipation}
-    $if mayRegister
+    <p>
-      ^{registerForm'}
+      _{MsgAllocationParticipationLoginFirst}
-    $else
-      $maybe Entity _ AllocationUser{allocationUserTotalCourses} <- registration
-        <dl .deflist>
-          <dt .deflist__dt>
-            _{MsgAllocationTotalCourses}
-          <dd .deflist__dd>
-            #{allocationUserTotalCourses}
 
 $if not (null courseWidgets)
   <section .allocation>
     <h2>
       _{MsgAllocationCourses}
-    <div .allocation__explanation>
+    <div .allocation__explanation .allocation__label>
       <p>_{MsgAllocationPriorityTip}
       <p>_{MsgAllocationPriorityRelative}
-    <div .allocation__priority-label>
+    <div .allocation__courses>
-      _{MsgAllocationPriority}
+      $forall courseWgt <- courseWidgets
-    $forall courseWgt <- courseWidgets
+        ^{courseWgt}
-      ^{courseWgt}

templates/allocation/show.lucius

@@ -0,0 +1,85 @@
+.allocation__label {
+  color: var(--color-fontsec);
+  font-style: italic;
+}
+
+.allocation__courses {
+  margin-top: 20px;
+}
+
+.allocation-course {
+  display: grid;
+  grid-template-columns: 140px 1fr;
+  grid-template-areas:
+    '.           name   '
+    'prio-label  prio   '
+    'instr-label instr  '
+    'form-label  form   ';
+
+  grid-gap: 5px 7px;
+  padding: 12px 10px;
+
+  &:last-child {
+    padding: 12px 10px 0 10px;
+  }
+
+  & + .allocation-course {
+    border-top: 1px solid var(--color-grey);
+  }
+
+
+  .allocation-course__priority {
+    grid-area: prio;
+  }
+  .allocation-course__priority-label {
+    grid-area: prio-label;
+    justify-self: end;
+    align-self: center;
+    text-align: right;
+  }
+
+  .allocation-course__name {
+    grid-area: name;
+
+    align-self: center;
+
+    font-size: 1.2rem;
+  }
+
+  .allocation-course__instructions {
+    grid-area: instr;
+  }
+  .allocation-course__instructions-label {
+    grid-area: instr-label;
+    justify-self: end;
+    text-align: right;
+  }
+
+  .allocation-course__application {
+    grid-area: form;
+  }
+  .allocation-course__application-label {
+    grid-area: form-label;
+    justify-self: end;
+    text-align: right;
+    padding-top: 6px;
+  }
+}
+
+@media (max-width: 426px) {
+  .allocation-course {
+    grid-template-columns: 1fr;
+    grid-template-areas:
+      'name       '
+      'prio-label '
+      'prio       '
+      'instr-label'
+      'instr      '
+      'form-label '
+      'form       ';
+  }
+  
+  .allocation-course__application-label {
+    padding-top: 0;
+  }
+}

templates/allocation/show/course.hamlet

@@ -1,20 +1,27 @@
-<div .allocation-course id=#{toPathPiece cID}>
+$if is _Just muid
+  <div .allocation-course__priority-label .allocation__label>
+    _{MsgAllocationPriority}
   <div .allocation-course__priority>
     $maybe prioView <- mApplyFormView' >>= afvPriority
       ^{fvInput prioView}
     $nothing
       _{MsgAllocationNoApplication}
-  <a .allocation-course__name href=@{CourseR courseTerm courseSchool courseShorthand CShowR}>
+<a .allocation-course__name href=@{CourseR courseTerm courseSchool courseShorthand CShowR} target="_blank">
-    #{courseName}
+  #{courseName}
-  $maybe aInst <- courseApplicationsInstructions
+$if hasApplicationTemplate || is _Just courseApplicationsInstructions
-    <div .allocation-course__instructions>
+  <div .allocation-course__instructions-label .allocation__label>
+    _{MsgCourseApplicationInstructionsApplication}
+  <div .allocation-course__instructions>
+    $maybe aInst <- courseApplicationsInstructions
       <p>
         #{aInst}
-      $if hasApplicationTemplate
+    $if hasApplicationTemplate
-        <p>
+      <p>
-          <a href=@{CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR}>
+        <a href=@{CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR}>
-            #{iconRegisterTemplate} _{MsgCourseApplicationTemplateApplication}
+          #{iconRegisterTemplate} _{MsgCourseApplicationTemplateApplication}
-  $maybe ApplicationFormView{ ..} <- mApplyFormView'
+$maybe ApplicationFormView{ ..} <- mApplyFormView'
-    <div .allocation-course__application uw-interactive-fieldset data-conditional-input=#{maybe "" fvId afvPriority} data-conditional-value="" data-conditional-negated>
+  <div .allocation-course__application-label .allocation__label :not overrideVisible:uw-interactive-fieldset data-conditional-input=#{maybe "" fvId afvPriority} data-conditional-value="" data-conditional-negated>
-      ^{renderFieldViews FormStandard afvForm}
+    _{MsgCourseApplication}
-      ^{snd afvButtons}
+  <div .allocation-course__application :not overrideVisible:uw-interactive-fieldset data-conditional-input=#{maybe "" fvId afvPriority} data-conditional-value="" data-conditional-negated>
+    ^{renderFieldViews FormStandard afvForm}
+    ^{snd afvButtons}

templates/default-layout.lucius

@@ -180,11 +180,15 @@ h4 {
   }
 
   p {
-    margin: 10px 0;
+    margin: 0.5rem 0;
-  }
 
-  p:last-child {
+    &:last-child {
-    margin: 10px 0 0;
+      margin: 0.5rem 0 0;
+    }
+
+    &:first-of-type {
+      margin: 0;
+    }
   }
 }
 
@@ -546,6 +550,7 @@ section {
 
     &:last-child {
         border-bottom: none;
+        padding-bottom: 0px;
     }
 }
 
@@ -564,33 +569,64 @@ section {
   border-radius: 3px;
   padding: 10px 20px 20px;
   margin: 40px 0;
-  color: var(--color-dark);
   box-shadow: 0 0 4px 2px inset currentColor;
-  padding-left: 20%;
+  padding-left: 100px;
   min-height: 100px;
+  max-width: 700px;
+  font-weight: 600;
+  vertical-align: center;
+  display: grid;
+  grid-column: 2;
 
   &::before {
-    content: 'i';
+    font-family: "Font Awesome 5 Free";
+    font-weight: 900;
     position: absolute;
     display: flex;
     left: 0;
     top: 0;
     height: 100%;
-    width: 20%;
+    width: 100px;
-    font-size: 100px;
+    font-size: 50px;
     align-items: center;
     justify-content: center;
   }
+
+  .notification__content {
+    grid-column: 1;
+    align-self: center;
+  }
 }
 
-.form-group__input > .notification {
+.form-section-notification {
-  margin: 0;
+  display: grid;
+  grid-template-columns: 1fr 3fr;
+  grid-gap: 5px;
+
+  .notification {
+    margin: 0;
+  }
+
+  + .form-group, + .form-section-legend, + .form-section-notification {
+    margin-top: 11px;
+  }
+
+  + .form-section-title {
+    margin-top: 40px;
+  }
 }
 
 @media (max-width: 768px) {
+  .form-section-notification {
+    grid-template-columns: 1fr;
+    margin-top: 17px;
+  }
 
   .notification {
+    grid-column: 1;
 
+    max-width: none;
+      
     padding-left: 40px;
 
     &::before {
@@ -602,16 +638,20 @@ section {
   }
 }
 
-.notification-danger {
+.notification-error {
-  color: #c51919 ;
+  color: var(--color-error) ;
-
-  &::before {
-    content: '!';
-  }
 }
 
-.notification__content {
+.notification-warning {
-  color: var(--color-font);
+  color: var(--color-warning) ;
+}
+
+.notification-info {
+  color: var(--color-lightblack) ;
+}
+
+.notification-success {
+  color: var(--color-warning) ;
 }
 
 

templates/widgets/aform/aform.hamlet

@@ -11,6 +11,9 @@ $case formLayout
       $if fvId view == idFormSectionNoinput
         <h3 .form-section-title>
           ^{fvLabel view}
+      $elseif fvId view == idFormMessageNoinput
+        <div .form-section-notification>
+          ^{fvInput view}
       $else
         <div .form-group .interactive-fieldset__target :fvRequired view:.form-group--required :not $ fvRequired view:.form-group--optional :isJust $ fvErrors view:.form-group--has-error>
           $if not (Blaze.null $ fvLabel view)