fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

Browse Source
This commit is contained in:
Gregor Kleen 2019-06-06 15:56:55 +02:00
commit 8a4c116f76
14 changed files with 3012 additions and 3312 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
messages/uniworx/de.msg
View File

@ -173,7 +173,6 @@ SheetMarking: Hinweise für Korrektoren
SheetMarkingFiles: Korrektur
SheetType: Wertung
SheetInvisible: Dieses Übungsblatt ist für Teilnehmer momentan unsichtbar!
SheetInvisibleUntil date@Text: Dieses Übungsblatt ist für Teilnehmer momentan unsichtbar bis #{date}!
SheetName: Name
SheetDescription: Hinweise für Teilnehmer
SheetGroup: Gruppenabgabe
@ -519,9 +518,9 @@ CorrectorMissing: Abwesend
CorrectorExcused: Entschuldigt
CorrectorStateTip: Abwesende Korrektoren bekommen bei späteren Übungsblättern mehr Korrekturen zum Ausgleich zugewiesen. Entschuldigte Korrektoren müssen nicht nacharbeiten.
DayIsAHoliday tid@TermId date@Text: #{date} ist ein Feiertag
DayIsOutOfLecture tid@TermId date@Text: #{date} ist außerhalb der Vorlesungszeit des #{display tid}
DayIsOutOfTerm tid@TermId date@Text: #{date} liegt nicht im #{display tid}
DayIsAHoliday tid@TermId name@Text date@Text: "#{name}" (#{date}) ist ein Feiertag
DayIsOutOfLecture tid@TermId name@Text date@Text: "#{name}" (#{date}) ist außerhalb der Vorlesungszeit des #{display tid}
DayIsOutOfTerm tid@TermId name@Text date@Text: "#{name}" (#{date}) liegt nicht im Semester #{display tid}
UploadModeNone: Kein Upload
UploadModeAny: Upload, beliebige Datei(en)
@ -547,7 +546,7 @@ CorrectorSubmissions: Abgabe extern mit Pseudonym
UserSubmissions: Direkte Abgabe
BothSubmissions: Abgabe direkt & extern mit Pseudonym
SheetCorrectorSubmissionsTip: Abgabe erfolgt über ein Uni2work-externes Verfahren (zumeist in Papierform durch Einwurf) unter Angabe eines persönlichen Pseudonyms. Korrektorn können mithilfe des Pseudonyms später Korrekturergebnisse in Uni2work eintragen, damit Sie sie einsehen können.
SheetCorrectorSubmissionsTip: Abgabe erfolgt über ein Uni2work-externes Verfahren (zumeist in Papierform durch Einwurf) unter Angabe eines persönlichen Pseudonyms. Korrektoren können mithilfe des Pseudonyms später Korrekturergebnisse in Uni2work eintragen, damit Sie sie einsehen können.
SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen.
SubmissionReplace: Abgabe ersetzen

6102
package-lock.json generated
View File

File diff suppressed because it is too large Load Diff

3
package.json
View File

@ -71,6 +71,7 @@
"webpack-cli": "^3.3.2"
},
"dependencies": {
"flatpickr": "^4.5.7"
"flatpickr": "^4.5.7",
"npm": "^6.9.0"
}
}

31
src/Handler/Corrections.hs
View File

@ -447,7 +447,10 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
unless (null unassignedUnauth) $ do
let submissionEncrypt = encrypt :: SubmissionId -> DB CryptoFileNameSubmission
unassignedUnauth' <- mapM submissionEncrypt $ Set.toList unassignedUnauth
$(addMessageFile Warning "templates/messages/submissionsAssignUnauthorized.hamlet")
let numUnassignedUnauth = fromIntegral $ length unassignedUnauth'
trigger = [whamlet|_{MsgSubmissionsAssignUnauthorized numUnassignedUnauth}|]
content = Right $(widgetFile "messages/submissionsAssignUnauthorized")
addMessageModal Warning trigger content
unless (null unassignedAuth) $ do
num <- updateWhereCount [SubmissionId <-. Set.toList unassignedAuth]
[ SubmissionRatingBy =. Just uid
@ -497,7 +500,10 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
unless (null unassignedUnauth) $ do
let submissionEncrypt = encrypt :: SubmissionId -> DB CryptoFileNameSubmission
unassignedUnauth' <- mapM submissionEncrypt $ Set.toList unassignedUnauth
$(addMessageFile Warning "templates/messages/submissionsAssignUnauthorized.hamlet")
let numUnassignedUnauth = fromIntegral $ length unassignedUnauth'
trigger = [whamlet|_{MsgSubmissionsAssignUnauthorized numUnassignedUnauth}|]
content = Right $(widgetFile "messages/submissionsAssignUnauthorized")
addMessageModal Warning trigger content
unless (null unassignedAuth) $ do
(assigned, stillUnassigned) <- assignSubmissions shid (Just unassignedAuth)
unless (null assigned) $
@ -802,9 +808,10 @@ postCorrectionsUploadR = do
(Just subs)
| null subs -> addMessageI Warning MsgNoCorrectionsUploaded
| otherwise -> do
subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission]
mr <- (toHtml .) <$> getMessageRender
addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
subs' <- traverse (\x -> (,) <$> encrypt x <*> encrypt x) $ Set.toList subs :: Handler [(CryptoFileNameSubmission, CryptoUUIDSubmission)]
let trigger = [whamlet|_{MsgCorrectionsUploaded (genericLength subs')}|]
content = Right $(widgetFile "messages/correctionsUploaded")
addMessageModal Success trigger content
let uploadForm = wrapForm upload def
{ formAction = Just $ SomeRoute CorrectionsUploadR
@ -880,8 +887,8 @@ postCorrectionsCreateR = do
, submissionRatingAssigned = Just now
, submissionRatingTime = Nothing
}
unless (null duplicate)
$(addMessageFile Warning "templates/messages/submissionCreateDuplicates.hamlet")
unless (null duplicate) $
addMessageModal Warning [whamlet|_{MsgSheetDuplicatePseudonym}|] $ Right $(widgetFile "messages/submissionCreateDuplicates")
existingSubUsers <- E.select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps')
@ -889,7 +896,9 @@ postCorrectionsCreateR = do
return submissionUser
unless (null existingSubUsers) . mapReaderT lift $ do
(Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: DB CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers
$(addMessageFile Warning "templates/messages/submissionCreateExisting.hamlet")
let trigger = [whamlet|_{MsgSheetCreateExisting}|]
content = Right $(widgetFile "messages/submissionCreateExisting")
addMessageModal Warning trigger content
let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps'
forM_ sps'' $ \spGroup
-> let
@ -1008,8 +1017,10 @@ postCorrectionsGradeR = do
, SubmissionRatingTime =. now <$ guard rated
]
| otherwise -> return Nothing
subs' <- traverse encrypt subs :: Handler [CryptoFileNameSubmission]
unless (null subs') $(addMessageFile Success "templates/messages/correctionsUploaded.hamlet")
subs' <- traverse (\x -> (,) <$> encrypt x <*> encrypt x) subs :: Handler [(CryptoFileNameSubmission, CryptoUUIDSubmission)]
let trigger = [whamlet|_{MsgCorrectionsUploaded (genericLength subs')}|]
content = Right $(widgetFile "messages/correctionsUploaded")
unless (null subs') $ addMessageModal Success trigger content
defaultLayout $
$(widgetFile "corrections-grade")

40
src/Handler/Sheet.hs
View File

@ -406,10 +406,6 @@ getSShowR tid ssh csh shn = do
hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ]
hasSolution <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetSolution ]
return (hasHints, hasSolution)
cTime <- Just <$> liftIO getCurrentTime
visibleFrom <- traverse (formatTime SelFormatDateTime) $ sheetVisibleFrom sheet
when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI Warning $
maybe MsgSheetInvisible MsgSheetInvisibleUntil visibleFrom
mPseudonym <- runMaybeT $ do
uid <- MaybeT maybeAuthId
Entity _ SheetPseudonym{sheetPseudonymPseudonym} <- MaybeT . runDB . getBy $ UniqueSheetPseudonymUser sid uid
@ -421,12 +417,14 @@ getSShowR tid ssh csh shn = do
, formEncoding = generateEnctype
, formSubmit = FormNoSubmit
}
defaultLayout $ do
setTitleI $ prependCourseTitle tid ssh csh $ SomeMessage shn
sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet
sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet
hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet
solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet
let visibleFrom = visibleUTCTime SelFormatDateTime <$> sheetVisibleFrom sheet
sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet
sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet
hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet
solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet
markingText <- runMaybeT $ assertM_ (Authorized ==) (evalAccessCorrector tid ssh csh) >> hoistMaybe (sheetMarkingText sheet)
$(widgetFile "sheetShow")
@ -580,14 +578,25 @@ handleSheetEdit tid ssh csh msId template dbAction = do
insert_ $ SheetEdit aid actTime sid
addMessageI Success $ MsgSheetEditOk tid ssh csh sfName
-- Sanity checks generating warnings only, but not errors!
warnTermDays tid [sfVisibleFrom, Just sfActiveFrom, Just sfActiveTo, sfHintFrom, sfSolutionFrom]
warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <-
[ (sfVisibleFrom, MsgSheetVisibleFrom)
, (Just sfActiveFrom, MsgSheetActiveFrom)
, (Just sfActiveTo, MsgSheetActiveTo)
, (sfHintFrom, MsgSheetSolutionFromTip)
, (sfSolutionFrom, MsgSheetSolutionFrom)
] ]
return True
when saveOkay $ redirect $ case msId of
Just _ -> CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB
Nothing -> CSheetR tid ssh csh sfName SCorrR
(FormFailure msgs) -> forM_ msgs $ (addMessage Error) . toHtml
_ -> runDB $ warnTermDays tid $ (join . (flip fmap template))
<$> [sfVisibleFrom, Just . sfActiveFrom, Just . sfActiveTo, sfHintFrom, sfSolutionFrom]
_ -> runDB $ warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <-
[(sfVisibleFrom =<< template, MsgSheetVisibleFrom)
,(sfActiveFrom <$> template, MsgSheetActiveFrom)
,(sfActiveTo <$> template, MsgSheetActiveTo)
,(sfHintFrom =<< template, MsgSheetSolutionFromTip)
,(sfSolutionFrom =<< template, MsgSheetSolutionFrom)
] ]
let pageTitle = maybe (MsgSheetTitleNew tid ssh csh)
(MsgSheetTitle tid ssh csh) mbshn
@ -691,11 +700,14 @@ correctorForm shid = wFormToAForm $ do
| applyDefaultLoads = defaultLoads'
| otherwise = currentLoads'
when (not (Map.null loads) && applyDefaultLoads) $
addMessageI Warning MsgCorrectorsDefaulted
countTutRes <- wreq checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads
-- when (not (Map.null loads) && applyDefaultLoads) $ -- Alert Message
-- addMessageI Warning MsgCorrectorsDefaulted
when (not (Map.null loads) && applyDefaultLoads) $ -- Alert Notification
wformMessage =<< messageI Warning MsgCorrectorsDefaulted
let
previousCorrectors :: E.SqlQuery (E.SqlExpr (Entity User))
previousCorrectors = E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> do

21
src/Handler/Utils.hs
View File

@ -8,7 +8,8 @@ import Utils.Lens
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
-- import qualified Data.Set (Set)
import Data.Map ((!))
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.CaseInsensitive (original)
-- import qualified Data.CaseInsensitive as CI
@ -199,15 +200,17 @@ prependCourseTitle tid ssh csh msg = UniWorXMessages
colonText :: Text
colonText = ":"
warnTermDays :: TermId -> [Maybe UTCTime] -> DB ()
warnTermDays tid times = do
warnTermDays :: (RenderMessage UniWorX msg) => TermId -> Map UTCTime msg -> DB ()
warnTermDays tid timeNames = do
Term{..} <- get404 tid
let alldays = Set.map utctDay $ Set.fromList $ catMaybes times
warnholidays = Set.intersection alldays $ Set.fromList termHolidays
outoftermdays = Set.filter (\d -> d < termStart || d > termEnd ) alldays
outoflecture = Set.filter (\d -> d < termLectureStart || d > termLectureEnd) alldays
MsgRenderer mr <- getMsgRenderer
let alldays = Map.keysSet timeNames
warnholidays = let hdays = Set.fromList termHolidays in
Set.filter (\(utctDay -> d) -> Set.member d hdays) alldays
outoftermdays = Set.filter (\(utctDay -> d) -> d < termStart || d > termEnd ) alldays
outoflecture = Set.filter (\(utctDay -> d) -> d < termLectureStart || d > termLectureEnd) alldays
`Set.difference` outoftermdays -- out of term implies out of lecture-time
warnI msg d = formatTime SelFormatDate d >>= \dt -> addMessageI Warning $ msg tid dt
warnI msg d = formatTime SelFormatDate d >>= \dt -> addMessageI Warning $ msg tid (mr (timeNames ! d)) dt
forM_ warnholidays $ warnI MsgDayIsAHoliday
forM_ outoflecture $ warnI MsgDayIsOutOfLecture
forM_ outoftermdays $ warnI MsgDayIsOutOfTerm
@ -250,7 +253,7 @@ guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadLogger h
guardAuthorizedFor link val =
val <$ guardM (lift $ (== Authorized) <$> evalAccessDB link False)
runAppLoggingT :: UniWorX -> LoggingT m a -> m a
runAppLoggingT app@(appLogger -> (_, loggerTVar)) = flip runLoggingT logFunc
where

2
src/Handler/Utils/Submission.hs
View File

@ -344,7 +344,7 @@ extractRatingsMsg = do
(Right $(widgetFile "messages/submissionFilesIgnored"))
addMessageWidget Warning ignoredModal
-- Nicht innerhalb von runDB aufrufen, damit das DB Rollback passieren kann!
-- | Nicht innerhalb von runDB aufrufen, damit das DB Rollback passieren kann!
msgSubmissionErrors :: (MonadHandler m, MonadCatch m, HandlerSite m ~ UniWorX) => m a -> m (Maybe a)
msgSubmissionErrors = flip catches
[ E.Handler $ \e -> Nothing <$ addMessageI Error (e :: RatingException)

38
src/Utils/Form.hs
View File

@ -533,6 +533,11 @@ renderWForm formLayout = renderAForm formLayout . wFormToAForm
idFormSectionNoinput :: Text
idFormSectionNoinput = "form-section-noinput"
-- | special id to identify form messages, see 'aformMessage' and 'formMessage'
-- currently only treated by form generation through 'renderAForm'
idFormMessageNoinput :: Text
idFormMessageNoinput = "form-message-noinput"
-- | Generates a form having just a form-section-header and no input title.
-- Currently only correctly rendered by 'renderAForm' and mforms using 'widget/form.hamlet'
-- Usage:
@ -550,7 +555,7 @@ aformSection = formToAForm . fmap (second pure) . formSection
wformSection :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> WForm m ()
wformSection = void . aFormToWForm . aformSection
formSection :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site msg) => msg -> MForm m (FormResult (), FieldView site) -- TODO: WIP, delete
formSection :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site msg) => msg -> MForm m (FormResult (), FieldView site)
formSection formSectionTitle = do
mr <- getMessageRender
return (FormSuccess (), FieldView
@ -562,8 +567,6 @@ formSection formSectionTitle = do
, fvInput = mempty
})
-------------------
-- Special Forms --
-------------------
@ -582,6 +585,33 @@ formSection' formSectionTitleSettings = mreq noinputField sectionSettings Nothin
sectionSettings = formSectionTitleSettings { fsId = Just idFormSectionNoinput }
-- | Similar to aformSection, generates a form having just a view widget, but no input.
-- Currently only correctly rendered by 'renderAForm' and mforms using 'widget/form.hamlet'
-- Usage:
-- @
-- (,) <$ formMessage (Message Info html1)
-- <*> areq intField "int here" Nothing
-- <* formSection (Message Warning html2)
-- <*> areq doubleField "double there " Nothing
-- <* submitButton
-- @
aformMessage :: (MonadHandler m) => Message -> AForm m ()
aformMessage = formToAForm . fmap (second pure) . formMessage
wformMessage :: (MonadHandler m) => Message -> WForm m ()
wformMessage = void . aFormToWForm . aformMessage
formMessage :: (MonadHandler m) => Message -> MForm m (FormResult (), FieldView site)
formMessage Message{..} = do
return (FormSuccess (), FieldView
{ fvLabel = mempty
, fvTooltip = Nothing
, fvId = idFormMessageNoinput
, fvErrors = Nothing
, fvRequired = False
, fvInput = [whamlet|<div .notification .notification-#{toPathPiece messageStatus}>#{messageContent}|]
})
---------------------
-- Form evaluation --
@ -635,7 +665,7 @@ runInputResult form = do
postRes <- runInputPostResult form
getRes <- runInputGetResult form
return $ case (postRes, getRes) of
(FormSuccess a, _) -> FormSuccess a
(FormSuccess a, _) -> FormSuccess a
(_, FormSuccess b) -> FormSuccess b
(postRes', _) -> postRes'

11
src/Utils/Frontend/Modal.hs
View File

@ -2,12 +2,14 @@ module Utils.Frontend.Modal
( Modal(..)
, customModal
, modal, msgModal
, addMessageModal
) where
import ClassyPrelude.Yesod
import Control.Lens
import Utils.Route
import Utils.Message
import Settings (widgetFile)
@ -61,3 +63,12 @@ msgModal modalTrigger' modalContent = do
customModal Modal{..}
where
modalTrigger mRoute triggerId = $(widgetFile "widgets/modal/trigger")
-- | add message alert with a short trigger widget, whose larger content is displayed in a modal
addMessageModal :: forall m site.
( MonadHandler m
, HandlerSite m ~ site
, Yesod site
) => MessageStatus -> WidgetT site IO () -> Either (SomeRoute site) (WidgetT site IO ()) -> m ()
addMessageModal ms trigger content = addMessageWidget ms $ msgModal trigger content

2
src/Utils/Message.hs
View File

@ -7,7 +7,6 @@ module Utils.Message
, messageI, messageIHamlet, messageFile, messageWidget
) where
import Data.Universe
import Utils.PathPiece
import Data.Aeson
@ -110,6 +109,7 @@ addMessageWidget :: forall m site.
, Yesod site
) => MessageStatus -> WidgetT site IO () -> m ()
-- ^ _Note_: `addMessageWidget` ignores `pageTitle` and `pageHead`
-- also see Utils.Frontend.Modal.addMessageModal for large alerts with modal links
addMessageWidget mc wgt = do
PageContent{pageBody} <- liftHandlerT $ widgetToPageContent wgt
addMessageIHamlet mc (const pageBody :: HtmlUrlI18n (SomeMessage site) (Route site))

52
templates/default-layout.lucius
View File

@ -554,3 +554,55 @@ section {
.headline-one {
margin-bottom: 10px;
}
/* Notification style used as requested by @hamanf in #298, but class was not globally available. Copied from dead-code. For @hamanf to clean up: */
.notification {
position: relative;
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%;
&::before {
content: 'i';
position: absolute;
display: flex;
left: 0;
top: 0;
height: 100%;
width: 20%;
font-size: 100px;
align-items: center;
justify-content: center;
}
}
@media (max-width: 768px) {
.notification {
padding-left: 40px;
&::before {
height: auto;
width: 45px;
font-size: 40px;
top: 15px;
}
}
}
.notification-danger {
color: #c51919 ;
&::before {
content: '!';
}
}
.notification__content {
color: var(--color-font);
}

4
templates/messages/correctionsUploaded.hamlet
View File

@ -1,6 +1,6 @@
_{MsgCorrectionsUploaded (genericLength subs')}
<ul>
$forall cID <- subs'
$forall (cID,uuid) <- subs'
<li>
#{toPathPiece cID}
^{simpleLink (toWidget (toPathPiece cID)) (CryptoUUIDDispatchR (ciphertext uuid))}

2
templates/messages/submissionsAssignUnauthorized.hamlet
View File

@ -1,4 +1,4 @@
_{MsgSubmissionsAssignUnauthorized (fromIntegral (length unassignedUnauth'))}
_{MsgSubmissionsAssignUnauthorized numUnassignedUnauth}
<ul>
$forall cID <- unassignedUnauth'

7
templates/sheetShow.hamlet
View File

@ -7,6 +7,13 @@ $maybe descr <- sheetDescription sheet
<section>
<dl .deflist>
<dt .deflist__dt>_{MsgAccessibleSince}
<dd .deflist__dd>
$maybe invisible <- visibleFrom
^{invisible}
$nothing
#{isVisible False}
_{MsgSheetInvisible}
<dt .deflist__dt>_{MsgSheetActiveFrom}
<dd .deflist__dd>#{sheetFrom}
<dt .deflist__dt>_{MsgSheetActiveTo}