diff --git a/frontend/src/utils/inputs/inputs.scss b/frontend/src/utils/inputs/inputs.scss index 643902d08..ae81b82d4 100644 --- a/frontend/src/utils/inputs/inputs.scss +++ b/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 { - margin-top: 7px; + + .form-group, + .form-section-legend, + .form-section-notification { + margin-top: 11px; } + .form-section-title { diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 0d12afe08..d43d2c7eb 100644 --- a/messages/uniworx/de.msg +++ b/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 diff --git a/src/Crypto/Hash/Instances.hs b/src/Crypto/Hash/Instances.hs new file mode 100644 index 000000000..66228a69e --- /dev/null +++ b/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 diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 5a032a6de..201091a2d 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/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) diff --git a/src/Foundation.hs b/src/Foundation.hs index 6b47320ad..68a223a94 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -283,8 +283,12 @@ instance RenderMessage UniWorX MsgLanguage where where mr = renderMessage foundation ls -instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where - renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route) +instance RenderMessage UniWorX (UnsupportedAuthPredicate AuthTag (Route UniWorX)) where + 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 diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 27fc5c809..ded5ebec7 100644 --- a/src/Handler/Admin.hs +++ b/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 diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs index 0b970cb0f..cae507c55 100644 --- a/src/Handler/Allocation/Application.hs +++ b/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 - (mApp, coursesNum, Course{..}) <- liftHandlerT . runDB $ do +applicationForm aId cid uid ApplicationFormMode{..} csrf = 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 ( afmApplicantEdit && is _Just mApp) BtnAllocationApplicationEdit - , guardOn ( afmApplicantEdit && is _Nothing mApp) BtnAllocationApply - , guardOn ( afmApplicantEdit && is _Just mApp) BtnAllocationApplicationRetract + [ guardOn (not afmApplicantEdit && is _Just mApp && afmLecturer) BtnAllocationApplicationRate + , guardOn ( afmApplicantEdit && is _Just mApp ) BtnAllocationApplicationEdit + , guardOn ( afmApplicantEdit && is _Nothing mApp ) BtnAllocationApply + , 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 -postAApplyR = fail "Not implemented" +editApplicationR :: AllocationId + -> 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 + } diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index b386021c3..53149712a 100644 --- a/src/Handler/Allocation/Show.hs +++ b/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| +
+ ^{wdgt} + |] $(widgetFile "allocation/show") diff --git a/src/Handler/Course/Application.hs b/src/Handler/Course/Application.hs index f4a1fcada..7bdbb62ba 100644 --- a/src/Handler/Course/Application.hs +++ b/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 diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index 860835bf3..123cc83ad 100644 --- a/src/Handler/Course/Register.hs +++ b/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 - | isn't _NoUpload courseApplicationsFiles || fromMaybe False hasFiles - -> let filesLinkField = Field{..} - where - fieldParse _ _ = return $ Right Nothing - fieldEnctype = mempty - fieldView theId _ attrs _ _ - = [whamlet| - $newline never - $case appFilesInfo - $of Just (True, appCID) - - _{filesMsg} - $of _ - - _{MsgCourseApplicationNoFiles} - |] - in void $ wforced filesLinkField (fslI filesMsg) Nothing - | otherwise - -> return () + when (isn't _NoUpload courseApplicationsFiles || fromMaybe False hasFiles) $ + let filesLinkField = Field{..} + where + fieldParse _ _ = return $ Right Nothing + fieldEnctype = mempty + fieldView theId _ attrs _ _ + = [whamlet| + $newline never + $case appFilesInfo + $of Just (True, appCID) + + _{filesMsg} + $of _ + + _{MsgCourseApplicationNoFiles} + |] + in void $ wforced filesLinkField (fslI filesMsg) Nothing + + when (fromMaybe False hasFiles && isn't _NoUpload courseApplicationsFiles) $ + wformMessage <=< messageIconI Info IconFileUpload $ bool MsgCourseRegistrationFilesNeedReupload MsgCourseApplicationFilesNeedReupload courseApplicationsRequired appFilesRes <- let mkFs | courseApplicationsRequired = bool MsgCourseApplicationFile MsgCourseApplicationArchive | otherwise = bool MsgCourseRegistrationFile MsgCourseRegistrationArchive diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 4a5cccef9..f1bf685b8 100644 --- a/src/Handler/Sheet.hs +++ b/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 diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 2f06cd252..a7de88025 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/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 diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index e9d357662..3b5894373 100644 --- a/src/Import/NoModel.hs +++ b/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) diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 1c9109490..3d2bf8a69 100644 --- a/src/Model/Migration.hs +++ b/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'. diff --git a/src/Utils.hs b/src/Utils.hs index db521a099..91a53cdb9 100644 --- a/src/Utils.hs +++ b/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}|] - unauthorizedI (UnsupportedAuthPredicate (toPathPiece tag) route) + tRoute <- toTextUrl 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 diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 3907253cb..326cef129 100644 --- a/src/Utils/DB.hs +++ b/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 diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index a56ebbdd3..8a4f951ac 100644 --- a/src/Utils/Form.hs +++ b/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|
#{messageContent}|] + , fvInput = [whamlet| + $newline never +
+
+ #{messageContent} + |] }) + where + defaultIcon = case messageStatus of + Success -> "check-circle" + Info -> "info-circle" + Warning -> "exclamation-circle" + Error -> "exclamation-triangle" --------------------- -- Form evaluation -- diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index a7f6ceeae..30f62a959 100644 --- a/src/Utils/Icon.hs +++ b/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 diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index c47836273..2ddabae17 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -155,6 +155,8 @@ makePrisms ''AuthenticationMode makeLenses_ ''CourseUserNote makeLenses_ ''CourseApplication + +makeLenses_ ''Allocation -- makeClassy_ ''Load diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index d72d065bf..908848873 100644 --- a/src/Utils/Message.hs +++ b/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 diff --git a/templates/allocation/show.hamlet b/templates/allocation/show.hamlet index 74711e783..d2406a677 100644 --- a/templates/allocation/show.hamlet +++ b/templates/allocation/show.hamlet @@ -34,28 +34,34 @@ $newline never
^{formatTimeRangeW SelFormatDateTime fromT allocationStaffAllocationTo} -$if mayRegister || is _Just registration +$if is _Just muid + $if mayRegister || is _Just registration +
+

+ _{MsgAllocationParticipation} + $if mayRegister + ^{registerForm'} + $else + $maybe Entity _ AllocationUser{allocationUserTotalCourses} <- registration +
+
+ _{MsgAllocationTotalCourses} +
+ #{allocationUserTotalCourses} +$else

_{MsgAllocationParticipation} - $if mayRegister - ^{registerForm'} - $else - $maybe Entity _ AllocationUser{allocationUserTotalCourses} <- registration -
-
- _{MsgAllocationTotalCourses} -
- #{allocationUserTotalCourses} +

+ _{MsgAllocationParticipationLoginFirst} $if not (null courseWidgets)

_{MsgAllocationCourses} -
+

_{MsgAllocationPriorityTip}

_{MsgAllocationPriorityRelative} -

- _{MsgAllocationPriority} - $forall courseWgt <- courseWidgets - ^{courseWgt} +
+ $forall courseWgt <- courseWidgets + ^{courseWgt} diff --git a/templates/allocation/show.lucius b/templates/allocation/show.lucius new file mode 100644 index 000000000..7e2e4f406 --- /dev/null +++ b/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; + } +} diff --git a/templates/allocation/show/course.hamlet b/templates/allocation/show/course.hamlet index 146844919..53992eed4 100644 --- a/templates/allocation/show/course.hamlet +++ b/templates/allocation/show/course.hamlet @@ -1,20 +1,27 @@ -
+$if is _Just muid +
+ _{MsgAllocationPriority}
$maybe prioView <- mApplyFormView' >>= afvPriority ^{fvInput prioView} $nothing _{MsgAllocationNoApplication} - - #{courseName} - $maybe aInst <- courseApplicationsInstructions -
+ + #{courseName} +$if hasApplicationTemplate || is _Just courseApplicationsInstructions +
+ _{MsgCourseApplicationInstructionsApplication} +
+ $maybe aInst <- courseApplicationsInstructions

#{aInst} - $if hasApplicationTemplate -

- - #{iconRegisterTemplate} _{MsgCourseApplicationTemplateApplication} - $maybe ApplicationFormView{ ..} <- mApplyFormView' -

- ^{renderFieldViews FormStandard afvForm} - ^{snd afvButtons} + $if hasApplicationTemplate +

+ + #{iconRegisterTemplate} _{MsgCourseApplicationTemplateApplication} +$maybe ApplicationFormView{ ..} <- mApplyFormView' +

+ _{MsgCourseApplication} +
+ ^{renderFieldViews FormStandard afvForm} + ^{snd afvButtons} diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index b1db5eea7..f929425ec 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -180,11 +180,15 @@ h4 { } p { - margin: 10px 0; - } + margin: 0.5rem 0; - p:last-child { - margin: 10px 0 0; + &:last-child { + 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%; - font-size: 100px; + width: 100px; + font-size: 50px; align-items: center; justify-content: center; } + + .notification__content { + grid-column: 1; + align-self: center; + } } -.form-group__input > .notification { - margin: 0; +.form-section-notification { + 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 { - color: #c51919 ; - - &::before { - content: '!'; - } +.notification-error { + color: var(--color-error) ; } -.notification__content { - color: var(--color-font); +.notification-warning { + color: var(--color-warning) ; +} + +.notification-info { + color: var(--color-lightblack) ; +} + +.notification-success { + color: var(--color-warning) ; } diff --git a/templates/widgets/aform/aform.hamlet b/templates/widgets/aform/aform.hamlet index c0bd83e13..844821fa2 100644 --- a/templates/widgets/aform/aform.hamlet +++ b/templates/widgets/aform/aform.hamlet @@ -11,6 +11,9 @@ $case formLayout $if fvId view == idFormSectionNoinput

^{fvLabel view} + $elseif fvId view == idFormMessageNoinput +
+ ^{fvInput view} $else
$if not (Blaze.null $ fvLabel view)