Merge branch 'master' into 205-klausuren
This commit is contained in:
Gregor Kleen
commit
7deb994c16
@ -245,7 +245,7 @@ export class AsyncTable {
|
||||
}
|
||||
|
||||
for (var kv of formData.entries()) {
|
||||
url.searchParams.append(encodeURIComponent(kv[0]), encodeURIComponent(kv[1]));
|
||||
url.searchParams.append(kv[0], kv[1]);
|
||||
}
|
||||
|
||||
return url;
|
||||
|
||||
@ -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
6102
package-lock.json
generated
File diff suppressed because it is too large
Load Diff
@ -71,6 +71,7 @@
|
||||
"webpack-cli": "^3.3.2"
|
||||
},
|
||||
"dependencies": {
|
||||
"flatpickr": "^4.5.7"
|
||||
"flatpickr": "^4.5.7",
|
||||
"npm": "^6.9.0"
|
||||
}
|
||||
}
|
||||
|
||||
1
routes
1
routes
@ -99,6 +99,7 @@
|
||||
/ex/unassigned SheetOldUnassignedR GET
|
||||
/ex/#SheetName SheetR:
|
||||
/show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
|
||||
/show/download SArchiveR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
|
||||
/edit SEditR GET POST
|
||||
/delete SDelR GET POST
|
||||
/subs SSubsR GET POST -- for lecturer only
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -364,7 +364,12 @@ getSShowR tid ssh csh shn = do
|
||||
-- return desired columns
|
||||
return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
|
||||
let colonnadeFiles = widgetColonnade $ mconcat
|
||||
[ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True))
|
||||
[ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype) ->
|
||||
let link = CSheetR tid ssh csh shn $ SZipR ftype in
|
||||
tellCell (Any True) $
|
||||
anchorCell link [whamlet|#{sheetFile2markup ftype} _{ftype}|]
|
||||
-- i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True))
|
||||
|
||||
-- , colFilePath (view _1) (\row -> let fType = view _3 row in let fName = view _1 row in (CSheetR tid ssh csh shn (SFileR (E.unValue fType) (E.unValue fName))))
|
||||
, sortable (Just "path") (i18nCell MsgFileTitle) $ \(E.Value fName,_,E.Value fType) -> anchorCell
|
||||
(CSheetR tid ssh csh shn (SFileR fType fName))
|
||||
@ -406,10 +411,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,15 +422,27 @@ 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 zipLink = CSheetR tid ssh csh shn SArchiveR
|
||||
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")
|
||||
|
||||
getSArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
|
||||
getSArchiveR tid ssh csh shn = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
let archiveName = (unpack . stripAll $ mr (prependCourseTitle tid ssh csh $ SomeMessage shn)) <.> "zip"
|
||||
sftArchive = CSheetR tid ssh csh shn . SZipR -- used to check access to SheetFileTypes
|
||||
allowedSFTs <- filterM (hasReadAccessTo . sftArchive) [minBound..maxBound]
|
||||
serveZipArchive archiveName $ sheetFilesSFTsQuery tid ssh csh shn allowedSFTs .| C.map entityVal
|
||||
|
||||
|
||||
getSPseudonymR, postSPseudonymR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
|
||||
getSPseudonymR = postSPseudonymR
|
||||
postSPseudonymR tid ssh csh shn = do
|
||||
@ -459,8 +472,10 @@ getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType
|
||||
getSFileR tid ssh csh shn sft file = serveOneFile $ sheetFileQuery tid ssh csh shn sft file .| C.map entityVal
|
||||
|
||||
getSZipR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> Handler TypedContent
|
||||
getSZipR tid ssh csh shn sft
|
||||
= serveSomeFiles (unpack (toPathPiece sft) <.> "zip") $ sheetFilesAllQuery tid ssh csh shn sft .| C.map entityVal
|
||||
getSZipR tid ssh csh shn sft = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
let archiveName = (unpack . stripAll $ mr (prependCourseTitle tid ssh csh $ SomeMessage shn)) <> "_" <> (unpack $ toPathPiece sft) <.> "zip"
|
||||
serveSomeFiles archiveName $ sheetFilesAllQuery tid ssh csh shn sft .| C.map entityVal
|
||||
|
||||
|
||||
getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
@ -580,14 +595,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 +717,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
|
||||
|
||||
@ -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
|
||||
@ -92,6 +93,23 @@ serveSomeFiles archiveName source = do
|
||||
let zipComment = T.encodeUtf8 $ pack archiveName
|
||||
source .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
|
||||
|
||||
-- | Serve any number of files as a zip-archive of files, identified through a given DB query
|
||||
--
|
||||
-- Like `serveSomeFiles`, but always sends a zip-archive, even if a single file is returned
|
||||
serveZipArchive :: FilePath -> Source (YesodDB UniWorX) File -> Handler TypedContent
|
||||
serveZipArchive archiveName source = do
|
||||
results <- runDB . runConduit $ source .| peekN 2
|
||||
|
||||
$logDebugS "serveZipArchive" . tshow $ length results
|
||||
|
||||
case results of
|
||||
[] -> notFound
|
||||
_moreFiles -> do
|
||||
setContentDisposition' $ Just archiveName
|
||||
respondSourceDB "application/zip" $ do
|
||||
let zipComment = T.encodeUtf8 $ pack archiveName
|
||||
source .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
|
||||
|
||||
|
||||
|
||||
---------
|
||||
@ -199,15 +217,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 +270,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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -204,6 +204,10 @@ boolSymbol False = fontAwesomeIcon "times"
|
||||
-- tickmark :: IsString a => a
|
||||
-- tickmark = fromString "✔"
|
||||
|
||||
-- | remove all Whitespace from Text
|
||||
stripAll :: Text -> Text
|
||||
stripAll = Text.filter (not . isSpace)
|
||||
|
||||
-- | Convert text as it is to Html, may prevent ambiguous types
|
||||
-- This function definition is mainly for documentation purposes
|
||||
text2Html :: Text -> Html
|
||||
@ -883,7 +887,7 @@ encodedSecretBoxOpen' :: (FromJSON a, MonadError EncodedSecretBoxException m)
|
||||
=> SecretBox.Key
|
||||
-> Text -> m a
|
||||
encodedSecretBoxOpen' sKey chunked = do
|
||||
let unchunked = Text.filter (not . isSpace) chunked
|
||||
let unchunked = stripAll chunked
|
||||
decoded <- either (throwError . EncodedSecretBoxInvalidBase64) return . Base64.decode $ encodeUtf8 unchunked
|
||||
|
||||
unless (BS.length decoded >= Saltine.secretBoxNonce + Saltine.secretBoxMac) $
|
||||
|
||||
@ -591,6 +591,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:
|
||||
@ -608,7 +613,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
|
||||
@ -620,8 +625,6 @@ formSection formSectionTitle = do
|
||||
, fvInput = mempty
|
||||
})
|
||||
|
||||
|
||||
|
||||
-------------------
|
||||
-- Special Forms --
|
||||
-------------------
|
||||
@ -640,6 +643,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 --
|
||||
@ -693,7 +723,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'
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -74,11 +74,29 @@ sheetFilesAllQuery tid ssh csh shn sft = E.selectSource $ E.from $
|
||||
E.on (sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
|
||||
E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId)
|
||||
-- filter to requested file
|
||||
E.where_ ((sFile E.^. SheetFileType E.==. E.val sft )
|
||||
E.&&. (sheet E.^. SheetName E.==. E.val shn )
|
||||
E.where_ ((sheet E.^. SheetName E.==. E.val shn )
|
||||
E.&&. (course E.^. CourseShorthand E.==. E.val csh )
|
||||
E.&&. (course E.^. CourseSchool E.==. E.val ssh )
|
||||
E.&&. (course E.^. CourseTerm E.==. E.val tid )
|
||||
E.&&. (sFile E.^. SheetFileType E.==. E.val sft )
|
||||
)
|
||||
-- return file entity
|
||||
return file
|
||||
|
||||
-- | Return all files of certain `SheetFileTypes` for a `Sheet`
|
||||
sheetFilesSFTsQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> [SheetFileType] -> Source (SqlPersistT m) (Entity File)
|
||||
sheetFilesSFTsQuery tid ssh csh shn sfts = E.selectSource $ E.from $
|
||||
\(course `E.InnerJoin` sheet `E.InnerJoin` sFile `E.InnerJoin` file) -> do
|
||||
-- Restrict to consistent rows that correspond to each other
|
||||
E.on (file E.^. FileId E.==. sFile E.^. SheetFileFile)
|
||||
E.on (sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
|
||||
E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId)
|
||||
-- filter to requested file
|
||||
E.where_ ((sheet E.^. SheetName E.==. E.val shn )
|
||||
E.&&. (course E.^. CourseShorthand E.==. E.val csh )
|
||||
E.&&. (course E.^. CourseSchool E.==. E.val ssh )
|
||||
E.&&. (course E.^. CourseTerm E.==. E.val tid )
|
||||
E.&&. (sFile E.^. SheetFileType `E.in_` E.valList sfts )
|
||||
)
|
||||
-- return file entity
|
||||
return 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);
|
||||
}
|
||||
|
||||
@ -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))}
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
_{MsgSubmissionsAssignUnauthorized (fromIntegral (length unassignedUnauth'))}
|
||||
_{MsgSubmissionsAssignUnauthorized numUnassignedUnauth}
|
||||
|
||||
<ul>
|
||||
$forall cID <- unassignedUnauth'
|
||||
|
||||
@ -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}
|
||||
@ -45,5 +52,5 @@ $maybe marktxt <- markingText
|
||||
|
||||
$if hasFiles
|
||||
<section>
|
||||
<h2>_{MsgSheetFiles}
|
||||
<h2>^{simpleLinkI (SomeMessage MsgSheetFiles) zipLink}
|
||||
^{fileTable}
|
||||
|
||||
@ -4,5 +4,5 @@ $maybe exts <- fmap toNullable permittedExtensions
|
||||
<br>
|
||||
_{MsgUploadModeExtensionRestriction}:
|
||||
<ul .list--inline .list--comma-separated .list--iconless>
|
||||
$forall ext <- zipExtensions <> exts
|
||||
$forall ext <- bool id (mappend zipExtensions) doUnpack exts
|
||||
<li style="font-family: monospace">#{ext}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user