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-05-09 14:57:15 +02:00
commit 4f45cca614
11 changed files with 102 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
routes
View File

@ -88,14 +88,14 @@
/users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant
/correctors CHiWisR GET
/communication CCommR GET POST
/notes CNotesR GET POST !corrector
/notes CNotesR GET POST !corrector -- THIS route is used to check for overall course corrector access!
/subs CCorrectionsR GET POST
/ex SheetListR GET !course-registered !materials !corrector
/ex/new SheetNewR GET POST
/ex/current SheetCurrentR GET !course-registered !materials !corrector
/ex/unassigned SheetOldUnassigned GET
/ex/#SheetName SheetR:
/show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector
/show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
/edit SEditR GET POST
/delete SDelR GET POST
/subs SSubsR GET POST -- for lecturer only
@ -110,9 +110,10 @@
/invite SInviteR GET POST !ownerANDtime
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector
/correctors SCorrR GET POST
/iscorrector SIsCorrR GET !corrector -- Route is used to check for corrector access to this sheet
/pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions
/corrector-invite/ SCorrInviteR GET POST
!/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registered !timeANDmaterials !corrector
!/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
/file MaterialListR GET !course-registered !materials !corrector !tutor
/file/new MaterialNewR GET POST
/file/#MaterialName MaterialR:

9
src/Handler/Course.hs
View File

@ -40,7 +40,7 @@ import Jobs.Queue
import Data.Aeson hiding (Result(..))
import Text.Hamlet (ihamlet)
-- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School)
@ -1298,8 +1298,9 @@ getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-- NOTE: The route getNotesR is abused for correctorORlecturer access rights!
-- PROBLEM: Correctors usually don't know Participants by name (anonymous), maybe notes are not shared?
-- If they are shared, adjust MsgCourseUserNoteTooltip
getCNotesR = error "CNotesR: Not implemented"
postCNotesR = error "CNotesR: Not implemented"
getCNotesR = postCNotesR
postCNotesR _ _ _ = do
defaultLayout $ [whamlet|You have corrector access to this course.|]
getCCommR, postCCommR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
@ -1355,7 +1356,7 @@ postCCommR tid ssh csh = do
evalAccessDB (CourseR tid ssh csh $ CUserR cID) False
}
getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCLecInviteR = postCLecInviteR
postCLecInviteR = invitationR lecturerInvitationConfig

8
src/Handler/Material.hs
View File

@ -170,13 +170,13 @@ getMShowR tid ssh csh mnm = do
let matLink :: FilePath -> Route UniWorX
matLink = CourseR tid ssh csh . MaterialR mnm . MFileR
seeAllModificationTimestamps <- hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- ordinary users should not see modification dates older than visibility
seeAllModificationTimestamps <- hasReadAccessTo $ CourseR tid ssh csh CNotesR -- ordinary users should not see modification dates older than visibility
( Entity _mid material@Material{materialType, materialDescription}
, (Any hasFiles,fileTable)) <- runDB $ do
matEnt <- fetchMaterial tid ssh csh mnm
let materialModDateCell :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c)
materialModDateCell = if seeAllModificationTimestamps
let materialModDateCol :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c)
materialModDateCol = if seeAllModificationTimestamps
then colFileModification
else colFileModificationWhen $ \t -> NTop (Just t) > NTop (materialVisibleFrom $ entityVal matEnt)
let psValidator = def & defaultSortingByFileTitle
@ -190,7 +190,7 @@ getMShowR tid ssh csh mnm = do
, dbtColonnade = widgetColonnade $ mconcat
[ dbRowIndicator -- important: contains writer to indicate that the tables is not empty
, colFilePathSimple (view $ _dbrOutput . _1) matLink
, materialModDateCell (view $ _dbrOutput . _2)
, materialModDateCol (view $ _dbrOutput . _2)
]
, dbtProj = \dbr -> guardAuthorizedFor (matLink $ dbr ^. _dbrOutput . _1 . _Value) dbr
, dbtStyle = def

44
src/Handler/Sheet.hs
View File

@ -296,19 +296,20 @@ instance Button UniWorX ButtonGeneratePseudonym where
-- Show single sheet
getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSShowR tid ssh csh shn = do
now <- liftIO getCurrentTime
Entity sid sheet <- runDB $ fetchSheet tid ssh csh shn
-- without Colonnade
-- fileNameTypes <- runDB $ E.select $ E.from $
-- \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
-- -- Restrict to consistent rows that correspond to each other
-- E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile)
-- E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
-- -- filter to requested file
-- E.where_ (sheet E.^. SheetId E.==. E.val sid )
-- -- return desired columns
-- return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
-- let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid ssh csh (SheetFileR shn fType fName),modified)) fileNameTypes
-- with Colonnade
seeAllModificationTimestamps <- hasReadAccessTo $ CSheetR tid ssh csh shn SIsCorrR -- ordinary users should not see modification dates older than visibility
let sftVisible :: IsDBTable m a => SheetFileType -> DBCell m a
sftVisible sft | Just dts <- sheetFileTypeDates sheet sft
= dateTimeCellVisible now dts
| otherwise = isVisibleCell False
sftModification :: IsDBTable m a => SheetFileType -> UTCTime -> DBCell m a
sftModification sft mtime
| seeAllModificationTimestamps = dateTimeCell mtime
| NTop (Just mtime) > NTop (sheetFileTypeDates sheet sft) = dateTimeCell mtime
| otherwise = mempty
let fileData (sheetFile `E.InnerJoin` file) = do
-- Restrict to consistent rows that correspond to each other
@ -320,12 +321,15 @@ getSShowR tid ssh csh shn = do
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))
-- , 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))
(str2widget fName)
-- , 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 (toNothing "visible") (i18nCell MsgVisibleFrom)
$ \(_, _ , E.Value ftype) -> sftVisible ftype
, sortable (Just "time") (i18nCell MsgFileModified)
$ \(_,E.Value modified, E.Value ftype) -> sftModification ftype modified
-- , colFileModification (view _2)
, sortable (Just "time") (i18nCell MsgFileModified) $ \(_,E.Value modified,_) -> dateTimeCell modified
]
let psValidator = def & defaultSorting [SortAscBy "type", SortAscBy "path"]
(Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
@ -345,6 +349,9 @@ getSShowR tid ssh csh shn = do
, ( "path"
, SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileTitle
)
-- , ( "visible"
-- , SortColumn $ \(sheetFile `E.InnerJoin` _file) -> sheetFileTypeDates sheet $ sheetFile E.^. SheetFileType -- not possible without another join for the sheet
-- )
, ( "time"
, SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileModified
)
@ -763,7 +770,7 @@ getSCorrR tid ssh csh shn = do
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
FormSuccess (autoDistribute, sheetCorrectors) -> runDBJobs $ do
update shid [ SheetAutoDistribute =. autoDistribute ]
let (invites, adds) = partitionEithers $ Set.toList sheetCorrectors
deleteWhere [ SheetCorrectorSheet ==. shid ]
@ -845,3 +852,10 @@ correctorInvitationConfig = InvitationConfig{..}
getSCorrInviteR, postSCorrInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSCorrInviteR = postSCorrInviteR
postSCorrInviteR = invitationR correctorInvitationConfig
getSIsCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
-- NOTE: The route SIsCorrR is only used to verfify corrector access rights to given sheet!
getSIsCorrR _ _ _ shn = do
defaultLayout $ [whamlet|You have corrector access to #{shn}.|]

9
src/Handler/Utils/Sheet.hs
View File

@ -7,6 +7,15 @@ import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Internal.Sql as E
-- | Map sheet file types to their visibily dates of a given sheet, for convenience
sheetFileTypeDates :: Sheet -> SheetFileType -> Maybe UTCTime
sheetFileTypeDates Sheet{..} = \case
SheetExercise -> Just sheetActiveFrom
SheetHint -> sheetHintFrom
SheetSolution -> sheetSolutionFrom
SheetMarking -> Nothing
fetchSheetAux :: ( BaseBackend backend ~ SqlBackend
, E.SqlSelect b a
, Typeable a, MonadHandler m, IsPersistBackend backend

24
src/Handler/Utils/Table/Cells.hs
View File

@ -54,9 +54,9 @@ sqlCell :: (IsDBTable (YesodDB UniWorX) a) => YesodDB UniWorX Widget -> DBCell (
sqlCell act = mempty & cellContents .~ lift act
-- | Highlight table cells with warning: Is not yet implemented in frontend.
markCell :: (IsDBTable m a) => (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a)
markCell condition normal x
| condition x = normal x & cellAttrs <>~ [("class","urgency__warning")] ---TODO: handle existing classe akin to Form.addAttr/addClass
markCell :: (IsDBTable m a) => MessageStatus -> (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a)
markCell status condition normal x
| condition x = normal x & over cellAttrs (insertAttr "class" $ statusToUrgencyClass status)
| otherwise = normal x
ifCell :: (IsDBTable m a) => (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a) -> (t -> DBCell m a)
@ -87,6 +87,12 @@ commentCell Nothing = mempty
commentCell (Just link) = anchorCell link icon
where icon = toWidget $ hasComment True
isVisibleCell :: (IsDBTable m a) => Bool -> DBCell m a
isVisibleCell True = cell . toWidget $ isVisible True
isVisibleCell False = (cell . toWidget $ isVisible False) & addUrgencyClass
where
addUrgencyClass = over cellAttrs $ insertClass $ statusToUrgencyClass Warning
-- | Display an icon that opens a modal upon clicking
modalCell :: (IsDBTable m a, ToWidget UniWorX w) => w -> DBCell m a
modalCell content = cell $ modal (toWidget $ hasComment True) (Right $ toWidget content)
@ -102,12 +108,14 @@ dateCell t = cell $ formatTime SelFormatDate t >>= toWidget
dateTimeCell :: IsDBTable m a => UTCTime -> DBCell m a
dateTimeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget
-- | Show a date, and highlight date earlier than given watershed with an icon
dateTimeCellVisible :: IsDBTable m a => UTCTime -> UTCTime -> DBCell m a
dateTimeCellVisible watershed t = cell $ do
let tfw = formatTimeW SelFormatDateTime t
icn :: Widget
icn = bool mempty (toWidget $ isVisible False) $ watershed < t
[whamlet|^{tfw}&nbsp;^{icn}|]
dateTimeCellVisible watershed t
| watershed < t = cell $(widgetFile "widgets/date-time/yet-invisible") & addUrgencyClass
| otherwise = cell timeStampWgt
where
timeStampWgt = formatTimeW SelFormatDateTime t
addUrgencyClass = over cellAttrs $ insertClass $ statusToUrgencyClass Warning
userCell :: IsDBTable m a => Text -> Text -> DBCell m a
userCell displayName surname = cell $ nameWidget displayName surname

19
src/Utils.hs
View File

@ -338,6 +338,25 @@ lastMaybe' :: [a] -> Maybe a
lastMaybe' l = fmap snd $ l ^? _Snoc
-- | Merge/Add any attribute-value pair to an existing list of such pairs.
-- If the attribute exists, the new valu will be prepended, separated by a single empty space
-- Also see `Utils.mergeAttrs`
insertAttr :: Text -> Text -> [(Text,Text)] -> [(Text,Text)]
insertAttr attr valu = aux
where
aux :: [(Text,Text)] -> [(Text,Text)]
aux [] = [(attr,valu)]
aux (p@(a,v) : t)
| attr==a = (a, Text.append valu $ Text.cons ' ' v) : t
| otherwise = p : aux t
-- | Add another class attribute; special function for a frequent case to avoid mistyping "class".
-- Also see `Utils.insertAttrs`
insertClass :: Text -> [(Text,Text)] -> [(Text,Text)]
insertClass = insertAttr "class"
-- | Append two lists of attributes, merging the class attribute only.
-- Also see `Utils.insertAttr` to merge any attribute
mergeAttrs :: [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
mergeAttrs = mergeAttrs' `on` sort
where

28
src/Utils/Form.hs
View File

@ -33,9 +33,10 @@ import Web.PathPieces
import Data.UUID
import Utils.Message
import Utils.PathPiece
import Utils.Route
import Utils
-- import Utils.Message
-- import Utils.PathPiece
-- import Utils.Route
import Data.Proxy
@ -82,23 +83,16 @@ fslpI lbl placeholder
, fsAttrs = [("placeholder", placeholder)]
}
-- NOTE: see Utils.insertAttrs for inserting/merging generic [[(Text,Text)] attributes
addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site
addAttr attr valu fs = fs { fsAttrs = newAttrs $ fsAttrs fs }
where
newAttrs :: [(Text,Text)] -> [(Text,Text)]
newAttrs [] = [(attr, valu)]
newAttrs (p@(a,v) : t)
| attr==a = (a, T.append valu $ cons ' ' v) : t
| otherwise = p : newAttrs t
addAttr attr valu fs = fs { fsAttrs = insertAttr attr valu $ fsAttrs fs }
addAttrs :: Text -> [Text] -> FieldSettings site -> FieldSettings site
addAttrs attr valus fs = fs { fsAttrs = newAttrs $ fsAttrs fs }
addAttrs attr valus fs = fs { fsAttrs = insertAttr attr valu $ fsAttrs fs }
where
newAttrs :: [(Text, Text)] -> [(Text, Text)]
newAttrs [] = [(attr, T.intercalate " " valus)]
newAttrs (p@(a,v) : t)
| attr==a = ( a, T.intercalate " " $ v : valus ) : t
| otherwise = p : newAttrs t
valu = T.intercalate " " valus
addPlaceholder :: Text -> FieldSettings site -> FieldSettings site
addPlaceholder placeholder fs = fs { fsAttrs = (placeholderAttr, placeholder) : filter ((/= placeholderAttr) . fst) (fsAttrs fs) }
@ -352,7 +346,7 @@ autosubmitButton = combinedButtonFieldF_ (Proxy @ButtonSubmit) $ "" & addAutosub
-- | just Html for a Submit-Button
submitButtonView :: forall site . Button site ButtonSubmit => WidgetT site IO ()
submitButtonView = buttonView BtnSubmit
buttonView :: forall site button. Button site button => button -> WidgetT site IO ()
buttonView btn = do
let bField :: Field (HandlerT site IO) button

3
src/Utils/Message.hs
View File

@ -2,6 +2,7 @@ module Utils.Message
( MessageStatus(..)
, UnknownMessageStatus(..)
, addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget
, statusToUrgencyClass
, Message(..)
, messageI, messageIHamlet, messageFile, messageWidget
) where
@ -67,6 +68,8 @@ instance FromJSON Message where
messageContent <- preEscapedText . sanitizeBalance <$> o .: "content"
return Message{..}
statusToUrgencyClass :: MessageStatus -> Text
statusToUrgencyClass status = "urgency__" <> toPathPiece status
addMessage :: MonadHandler m => MessageStatus -> Html -> m ()
addMessage mc = ClassyPrelude.Yesod.addMessage (toPathPiece mc)

2
templates/table/cell/body.hamlet
View File

@ -1,4 +1,4 @@
$newline never
<td *{mergeAttrs attrs [("class", "table__td")]}>
<td *{insertClass "table__td" attrs}>
<div .table__td-content>
^{widget}

1
templates/widgets/date-time/yet-invisible.hamlet Normal file
View File

@ -0,0 +1 @@
^{timeStampWgt}&nbsp;#{isVisible False}