143 lines
6.4 KiB
Haskell
143 lines
6.4 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
|
|
|
module Handler.Submission.AuthorshipStatements
|
|
( getSubAuthorshipStatementsR
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
|
|
type AuthorshipStatementsExpr = E.SqlExpr (Entity AuthorshipStatementSubmission)
|
|
`E.InnerJoin` E.SqlExpr (Entity User)
|
|
`E.InnerJoin` E.SqlExpr (Entity AuthorshipStatementDefinition)
|
|
|
|
queryAuthorshipStatement :: Getter AuthorshipStatementsExpr (E.SqlExpr (Entity AuthorshipStatementSubmission))
|
|
queryAuthorshipStatement = to $(E.sqlIJproj 3 1)
|
|
|
|
queryUser :: Getter AuthorshipStatementsExpr (E.SqlExpr (Entity User))
|
|
queryUser = to $(E.sqlIJproj 3 2)
|
|
|
|
queryDefinition :: Getter AuthorshipStatementsExpr (E.SqlExpr (Entity AuthorshipStatementDefinition))
|
|
queryDefinition = to $(E.sqlIJproj 3 3)
|
|
|
|
|
|
type AuthorshipStatementsData = DBRow ( Entity AuthorshipStatementSubmission
|
|
, Entity User
|
|
, Entity AuthorshipStatementDefinition
|
|
)
|
|
|
|
resultAuthorshipStatement :: Lens' AuthorshipStatementsData (Entity AuthorshipStatementSubmission)
|
|
resultAuthorshipStatement = _dbrOutput . _1
|
|
|
|
resultUser :: Lens' AuthorshipStatementsData (Entity User)
|
|
resultUser = _dbrOutput . _2
|
|
|
|
resultDefinition :: Lens' AuthorshipStatementsData (Entity AuthorshipStatementDefinition)
|
|
resultDefinition = _dbrOutput . _3
|
|
|
|
|
|
getSubAuthorshipStatementsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
|
|
getSubAuthorshipStatementsR tid ssh csh shn cID = do
|
|
authorshipStatementTable <- runDB $ do
|
|
subId <- decrypt cID
|
|
Submission{..} <- get404 subId
|
|
isLecturer <- (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SSubsR) True
|
|
mASDefinition <- getSheetAuthorshipStatement =<< getEntity404 submissionSheet
|
|
|
|
let dbtIdent :: Text
|
|
dbtIdent = "authorship-statements"
|
|
|
|
dbtSQLQuery = runReaderT $ do
|
|
authorshipStatement <- view queryAuthorshipStatement
|
|
user <- view queryUser
|
|
definition <- view queryDefinition
|
|
|
|
lift $ do
|
|
E.on $ definition E.^. AuthorshipStatementDefinitionId E.==. authorshipStatement E.^. AuthorshipStatementSubmissionStatement
|
|
E.on $ user E.^. UserId E.==. authorshipStatement E.^. AuthorshipStatementSubmissionUser
|
|
|
|
E.where_ $ authorshipStatement E.^. AuthorshipStatementSubmissionSubmission E.==. E.val subId
|
|
|
|
return (authorshipStatement, user, definition)
|
|
dbtRowKey = views queryAuthorshipStatement (E.^. AuthorshipStatementSubmissionId)
|
|
|
|
dbtProj = dbtProjId
|
|
|
|
dbtColonnade :: Colonnade Sortable AuthorshipStatementsData (DBCell (HandlerFor UniWorX) ())
|
|
dbtColonnade = mconcat $ catMaybes
|
|
[ pure . sortable (Just "authorship-statement-time") (i18nCell MsgSubmissionColumnAuthorshipStatementTime) $ views (resultAuthorshipStatement . _entityVal . _authorshipStatementSubmissionTime) dateTimeCell
|
|
, pure $ colUserDisplayName (resultUser . _entityVal . $(multifocusG 2) _userDisplayName _userSurname)
|
|
, guardOn isLecturer $ colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
|
|
, pure $ lmap (view $ resultUser . _entityVal) colUserEmail
|
|
, pure . sortable Nothing (i18nCell MsgSubmissionColumnAuthorshipStatementWording) $ views resultDefinition definitionCell
|
|
]
|
|
where
|
|
definitionCell (Entity asdId asd)
|
|
= withColor . (cellAttrs %~ addAttrsClass "table__td--center") . modalCell $ authorshipStatementWidget asd
|
|
where
|
|
withColor c
|
|
| Just (Entity currASDId _) <- mASDefinition
|
|
= c
|
|
& cellAttrs %~ addAttrsClass "heated"
|
|
& cellAttrs <>~ pure ("style", [st|--hotness: #{tshow (boolHeat (asdId /= currASDId))}|])
|
|
| otherwise
|
|
= c
|
|
|
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
|
|
dbtSorting = mconcat
|
|
[ singletonMap "authorship-statement-time" . SortColumn $ views queryAuthorshipStatement (E.^. AuthorshipStatementSubmissionTime)
|
|
, sortUserName' (queryUser . $(multifocusG 2) (to (E.^. UserDisplayName)) (to (E.^. UserSurname)))
|
|
, sortUserMatriculation (queryUser . to (E.^. UserMatrikelnummer))
|
|
, uncurry singletonMap $ sortUserEmail (view queryUser)
|
|
]
|
|
dbtFilter = mconcat
|
|
[ fltrUserName' (queryUser . to (E.^. UserDisplayName))
|
|
, fltrUserMatriculation (queryUser . to (E.^. UserMatrikelnummer))
|
|
, uncurry singletonMap $ fltrUserEmail (view queryUser)
|
|
, singletonMap "authorship-statement-current" . FilterColumn $ \(view queryAuthorshipStatement -> subStmt) (Last isCurrent)
|
|
-> let isCurrent'
|
|
| Just (Entity asdId _) <- mASDefinition
|
|
= subStmt E.^. AuthorshipStatementSubmissionStatement E.==. E.val asdId
|
|
| otherwise
|
|
= E.false
|
|
in maybe E.true ((E.==. isCurrent') . E.val) isCurrent
|
|
]
|
|
|
|
dbtFilterUI = mconcat $ catMaybes
|
|
[ pure fltrUserNameUI'
|
|
, guardOn isLecturer fltrUserMatriculationUI
|
|
, pure fltrUserEmailUI
|
|
, pure . flip (prismAForm $ singletonFilter "authorship-statement-current" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgSubmissionFilterAuthorshipStatementCurrent)
|
|
]
|
|
|
|
dbtParams = def
|
|
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
|
|
asPSValidator = def
|
|
& defaultSorting [SortDescBy "authorship-statement-time"]
|
|
& restrictFilter lecturerFilter & restrictSorting lecturerSorting
|
|
where
|
|
lecturerFilter fk _
|
|
| isLecturer = True
|
|
| otherwise = fk /= "user-matriculation"
|
|
lecturerSorting sk _
|
|
| isLecturer = True
|
|
| otherwise = sk /= "user-matriculation"
|
|
in dbTableWidget' asPSValidator DBTable{..}
|
|
|
|
let (heading, title) = ( MsgSubmissionAuthorshipStatementsHeading tid ssh csh shn cID
|
|
, MsgSubmissionAuthorshipStatementsTitle tid ssh csh shn cID
|
|
)
|
|
|
|
siteLayoutMsg heading $ do
|
|
setTitleI title
|
|
|
|
authorshipStatementTable
|