Sheet: icon mark unpublished files works now
This commit is contained in:
Steffen Jost
parent
6182e94143
commit
b908fc4cf3
3
routes
3
routes
@ -88,7 +88,7 @@
|
||||
/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
|
||||
@ -109,6 +109,7 @@
|
||||
/correction CorrectionR GET POST !corrector !ownerANDreadANDrated
|
||||
!/#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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -298,18 +298,18 @@ 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
|
||||
@ -321,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,_) -> dateTimeCellVisible now modified
|
||||
]
|
||||
let psValidator = def & defaultSorting [SortAscBy "type", SortAscBy "path"]
|
||||
(Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
|
||||
@ -346,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
|
||||
)
|
||||
@ -846,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}.|]
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
@ -109,7 +115,7 @@ dateTimeCellVisible watershed t
|
||||
| otherwise = cell timeStampWgt
|
||||
where
|
||||
timeStampWgt = formatTimeW SelFormatDateTime t
|
||||
addUrgencyClass = over cellAttrs $ insertAttr "class" $ statusToUrgencyClass Warning
|
||||
addUrgencyClass = over cellAttrs $ insertClass $ statusToUrgencyClass Warning
|
||||
|
||||
userCell :: IsDBTable m a => Text -> Text -> DBCell m a
|
||||
userCell displayName surname = cell $ nameWidget displayName surname
|
||||
|
||||
21
src/Utils.hs
21
src/Utils.hs
@ -335,7 +335,26 @@ lastMaybe (_:t) = lastMaybe t
|
||||
lastMaybe' :: [a] -> Maybe a
|
||||
lastMaybe' l = fmap snd $ l ^? _Snoc
|
||||
|
||||
-- | Merge two lists of attribures, also see `Utils.Form.insertAttrs`
|
||||
|
||||
-- | 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
|
||||
|
||||
@ -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,17 +83,8 @@ fslpI lbl placeholder
|
||||
, fsAttrs = [("placeholder", placeholder)]
|
||||
}
|
||||
|
||||
-- | Merge/Add an 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, T.append valu $ cons ' ' v) : t
|
||||
| otherwise = p : aux t
|
||||
|
||||
-- NOTE: see Utils.insertAttrs for inserting/merging generic [[(Text,Text)] attributes
|
||||
|
||||
addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site
|
||||
addAttr attr valu fs = fs { fsAttrs = insertAttr attr valu $ fsAttrs fs }
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
$newline never
|
||||
<td *{mergeAttrs attrs [("class", "table__td")]}>
|
||||
<td *{insertClass "table__td" attrs}>
|
||||
<div .table__td-content>
|
||||
^{widget}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user