feat(corrections-r): authorship statement state
This commit is contained in:
Gregor Kleen
parent
57ea5fe329
commit
51522efc7c
@ -62,7 +62,7 @@ postCorrectionsGradeR = do
|
||||
& restrictAnonymous
|
||||
& restrictCorrector
|
||||
& defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData))
|
||||
unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
|
||||
unFormResult = getDBFormResult $ \(view $ resultSubmission . _entityVal -> sub@Submission{..}) -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
|
||||
|
||||
(fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns filterUI psValidator $ def
|
||||
{ dbParamsFormAction = Just $ SomeRoute CorrectionsGradeR
|
||||
|
||||
@ -31,18 +31,6 @@ import Handler.Submission.SubmissionUserInvite
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
|
||||
|
||||
data AuthorshipStatementSubmissionState
|
||||
= ASExists
|
||||
| ASOldStatement
|
||||
| ASMissing
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
nullaryPathPiece ''AuthorshipStatementSubmissionState $ camelToPathPiece' 1
|
||||
|
||||
embedRenderMessage ''UniWorX ''AuthorshipStatementSubmissionState $ concat . ("SubmissionAuthorshipStatementState" :) . drop 1 . splitCamel
|
||||
|
||||
|
||||
makeSubmissionForm :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m)
|
||||
=> CourseId -> SheetId -> Maybe (Entity AuthorshipStatementDefinition) -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Maybe FileUploads -> Bool -> Set (Either UserEmail UserId)
|
||||
-> (Markup -> MForm (ReaderT SqlBackend m) (FormResult (Maybe FileUploads, Set (Either UserEmail UserId), Maybe AuthorshipStatementDefinitionId), Widget))
|
||||
@ -606,28 +594,10 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
|
||||
subUsers <- maybeT (return []) $ do
|
||||
subId <- hoistMaybe msmid
|
||||
let
|
||||
getUserAuthorshipStatement :: UserId
|
||||
-> DB AuthorshipStatementSubmissionState
|
||||
getUserAuthorshipStatement uid = runConduit $
|
||||
getStmts
|
||||
.| fmap toRes (execWriterC . C.mapM_ $ tell . toPoint)
|
||||
where
|
||||
getStmts = E.selectSource . E.from $ \authorshipStatementSubmission -> do
|
||||
E.where_ $ authorshipStatementSubmission E.^. AuthorshipStatementSubmissionSubmission E.==. E.val subId
|
||||
E.&&. authorshipStatementSubmission E.^. AuthorshipStatementSubmissionUser E.==. E.val uid
|
||||
return authorshipStatementSubmission
|
||||
toPoint :: Entity AuthorshipStatementSubmission -> Maybe Any
|
||||
toPoint (Entity _ AuthorshipStatementSubmission{..}) = Just . Any $ fmap entityKey mASDefinition == Just authorshipStatementSubmissionStatement
|
||||
toRes :: Maybe Any -> AuthorshipStatementSubmissionState
|
||||
toRes = \case
|
||||
Just (Any True) -> ASExists
|
||||
Just (Any False) -> ASOldStatement
|
||||
Nothing -> ASMissing
|
||||
lift $ buddies
|
||||
& bool id (maybe id (Set.insert . Right) muid) isOwner
|
||||
& Set.toList
|
||||
& mapMOf (traverse . _Right) (\uid -> (,,) <$> (encrypt uid :: DB CryptoUUIDUser) <*> getJust uid <*> getUserAuthorshipStatement uid)
|
||||
& mapMOf (traverse . _Right) (\uid -> (,,) <$> (encrypt uid :: DB CryptoUUIDUser) <*> getJust uid <*> getUserAuthorshipStatement mASDefinition subId uid)
|
||||
& fmap (sortOn . over _Right $ (,,,) <$> views _2 userSurname <*> views _2 userDisplayName <*> views _2 userEmail <*> view _1)
|
||||
|
||||
subUsersVisible <- orM
|
||||
|
||||
@ -8,8 +8,9 @@ module Handler.Submission.List
|
||||
, correctionsR'
|
||||
, restrictAnonymous, restrictCorrector
|
||||
, ratedBy, courseIs, sheetIs, userIs
|
||||
, colTerm, colSchool, colCourse, colSheet, colCorrector, colSubmissionLink, colSelect, colSubmittors, colSMatrikel, colRating, colAssigned, colRated, colPseudonyms, colRatedField, colPointsField, colMaxPointsField, colCommentField, colLastEdit, colSGroups
|
||||
, filterUICourse, filterUITerm, filterUISchool, filterUISheetSearch, filterUIIsRated, filterUISubmission, filterUIUserNameEmail, filterUIUserMatrikelnummer, filterUICorrectorNameEmail, filterUIIsAssigned, filterUISubmissionGroup, filterUIRating, filterUIComment, filterUIPseudonym
|
||||
, resultSubmission
|
||||
, colTerm, colSchool, colCourse, colSheet, colCorrector, colSubmissionLink, colSelect, colSubmittors, colSMatrikel, colRating, colAssigned, colRated, colPseudonyms, colRatedField, colPointsField, colMaxPointsField, colCommentField, colLastEdit, colSGroups, colAuthorshipStatementState
|
||||
, filterUICourse, filterUITerm, filterUISchool, filterUISheetSearch, filterUIIsRated, filterUISubmission, filterUIUserNameEmail, filterUIUserMatrikelnummer, filterUICorrectorNameEmail, filterUIIsAssigned, filterUISubmissionGroup, filterUIRating, filterUIComment, filterUIPseudonym, filterUIAuthorshipStatementState
|
||||
, makeCorrectionsTable
|
||||
, CorrectionTableData, CorrectionTableWhere
|
||||
, ActionCorrections(..), downloadAction, deleteAction, assignAction, autoAssignAction
|
||||
@ -33,6 +34,8 @@ import Database.Esqueleto.Utils.TH
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
|
||||
import Text.Hamlet (ihamletFile)
|
||||
|
||||
import Database.Persist.Sql (updateWhereCount)
|
||||
@ -43,12 +46,14 @@ import Data.List (genericLength)
|
||||
data CorrectionTableFilterProj = CorrectionTableFilterProj
|
||||
{ corrProjFilterSubmission :: Maybe (Set [CI Char])
|
||||
, corrProjFilterPseudonym :: Maybe (Set [CI Char])
|
||||
, corrProjFilterAuthorshipStatementState :: Last AuthorshipStatementSubmissionState
|
||||
}
|
||||
|
||||
instance Default CorrectionTableFilterProj where
|
||||
def = CorrectionTableFilterProj
|
||||
{ corrProjFilterSubmission = Nothing
|
||||
, corrProjFilterPseudonym = Nothing
|
||||
, corrProjFilterAuthorshipStatementState = Last Nothing
|
||||
}
|
||||
|
||||
makeLenses_ ''CorrectionTableFilterProj
|
||||
@ -70,6 +75,7 @@ type CorrectionTableData = DBRow ( Entity Submission
|
||||
, Map UserId CorrectionTableUserData
|
||||
, CryptoFileNameSubmission
|
||||
, Bool {- Access to non-anonymous submission data -}
|
||||
, Maybe AuthorshipStatementSubmissionState
|
||||
)
|
||||
|
||||
|
||||
@ -135,6 +141,9 @@ resultCryptoID = _dbrOutput . _7
|
||||
resultNonAnonymousAccess :: Lens' CorrectionTableData Bool
|
||||
resultNonAnonymousAccess = _dbrOutput . _8
|
||||
|
||||
resultASState :: Lens' CorrectionTableData (Maybe AuthorshipStatementSubmissionState)
|
||||
resultASState = _dbrOutput . _9
|
||||
|
||||
|
||||
-- Where Clauses
|
||||
ratedBy :: UserId -> CorrectionTableWhere
|
||||
@ -291,6 +300,22 @@ colCommentField' l = sortable (Just "comment") (i18nCell MsgRatingComment) $ (ce
|
||||
colLastEdit :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colLastEdit = sortable (Just "last-edit") (i18nCell MsgTableLastEdit) $ \x -> maybeCell (x ^? resultLastEdit) dateTimeCell
|
||||
|
||||
colAuthorshipStatementState :: forall m a. IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colAuthorshipStatementState = sortable (Just "as-state") (i18nCell MsgSubmissionUserAuthorshipStatementState) $ \x ->
|
||||
let heatC :: AuthorshipStatementSubmissionState -> DBCell m a -> DBCell m a
|
||||
heatC s c
|
||||
= c
|
||||
& cellAttrs %~ addAttrsClass "heated"
|
||||
& cellAttrs <>~ pure ("style", [st|--hotness: #{tshow (boolHeat (s /= ASExists))}|])
|
||||
tid = x ^. resultCourseTerm
|
||||
ssh = x ^. resultCourseSchool
|
||||
csh = x ^. resultCourseShorthand
|
||||
shn = x ^. resultSheet . _entityVal . _sheetName
|
||||
cID = x ^. resultCryptoID
|
||||
|
||||
asRoute = CSubmissionR tid ssh csh shn cID SubAuthorshipStatementsR
|
||||
in maybeCell (x ^. resultASState) (\s -> heatC s $ anchorCell asRoute (i18n s :: Widget))
|
||||
|
||||
|
||||
filterUICourse :: Handler (OptionList Text) -> DBFilterUI
|
||||
filterUICourse courseOptions = flip (prismAForm $ singletonFilter "course") $ aopt (lift `hoistField` selectField courseOptions) (fslI MsgTableCourse)
|
||||
@ -326,7 +351,7 @@ filterUIIsAssigned :: DBFilterUI
|
||||
filterUIIsAssigned = flip (prismAForm $ singletonFilter "isassigned" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableHasCorrector)
|
||||
|
||||
filterUISubmissionGroup :: DBFilterUI
|
||||
filterUISubmissionGroup = flip (prismAForm $ singletonFilter "submittors-group") $ aopt textField (fslI MsgTableSubmissionGroup)
|
||||
filterUISubmissionGroup = flip (prismAForm $ singletonFilter "submission-group") $ aopt textField (fslI MsgTableSubmissionGroup)
|
||||
|
||||
filterUIRating :: DBFilterUI
|
||||
filterUIRating = flip (prismAForm $ singletonFilter "rating" . maybePrism _PathPiece) $ aopt (lift `hoistField` pointsField) (fslI MsgColumnRatingPoints)
|
||||
@ -334,6 +359,9 @@ filterUIRating = flip (prismAForm $ singletonFilter "rating" . maybePrism _PathP
|
||||
filterUIComment :: DBFilterUI
|
||||
filterUIComment mPrev = singletonMap "comment" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgRatingComment) (Just <$> listToMaybe =<< (Map.lookup "comment" =<< mPrev))
|
||||
|
||||
filterUIAuthorshipStatementState :: DBFilterUI
|
||||
filterUIAuthorshipStatementState = flip (prismAForm $ singletonFilter "as-state" . maybePrism _PathPiece) $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) optionsFinite :: Field _ AuthorshipStatementSubmissionState) (fslI MsgSubmissionUserAuthorshipStatementState)
|
||||
|
||||
|
||||
makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
|
||||
=> CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> _ -> PSValidator m x -> DBParams m x -> DB (DBResult m x)
|
||||
@ -368,6 +396,13 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams
|
||||
let haystack = map CI.mk . unpack $ toPathPiece cid
|
||||
in guard $ any (`isInfixOf` haystack) criteria
|
||||
|
||||
mASDefinition <- lift . lift . $cachedHereBinary shId $ getSheetAuthorshipStatement sheet
|
||||
asState <- for mASDefinition $ \_ ->
|
||||
lift . lift . $cachedHereBinary sId $ getSubmissionAuthorshipStatement mASDefinition sId
|
||||
|
||||
forMM_ (preview $ _dbtProjFilter . _corrProjFilterAuthorshipStatementState . _Wrapped . _Just) $ \criterion ->
|
||||
guard $ asState == Just criterion
|
||||
|
||||
submittors <- lift . lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do
|
||||
E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId)
|
||||
E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId)
|
||||
@ -392,7 +427,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams
|
||||
(return $ not sheetAnonymousCorrection)
|
||||
(hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR)
|
||||
|
||||
return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap, cid, nonAnonymousAccess)
|
||||
return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap, cid, nonAnonymousAccess, asState)
|
||||
dbtRowKey = views querySubmission (E.^. SubmissionId)
|
||||
dbtSorting = mconcat
|
||||
[ singletonMap "term" . SortColumn $ views queryCourse (E.^. CourseTerm)
|
||||
@ -418,7 +453,8 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams
|
||||
, singletonMap "submittors-pseudonyms" . SortProjected . comparing $ \x -> setOf (resultSubmittors . resultUserPseudonym . re _PseudonymText) x
|
||||
, singletonMap "comment" . SortColumn $ views querySubmission (E.^. SubmissionRatingComment) -- sorting by comment specifically requested by correctors to easily see submissions to be done
|
||||
, singletonMap "last-edit" . SortColumn $ view queryLastEdit
|
||||
, singletonMap "submission" . SortProjected . comparing $ toPathPiece . view resultCryptoID
|
||||
, singletonMap "submission" . SortProjected . comparing $ views resultCryptoID toPathPiece
|
||||
, singletonMap "as-state" . SortProjected . comparing $ view resultASState
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[ singletonMap "term" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseTerm)
|
||||
@ -461,6 +497,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams
|
||||
, singletonMap "comment" . FilterColumn . E.mkContainsFilterWith Just $ views querySubmission (E.^. SubmissionRatingComment)
|
||||
, singletonMap "submission" $ FilterProjected (_corrProjFilterSubmission ?~)
|
||||
, singletonMap "pseudonym" $ FilterProjected (_corrProjFilterPseudonym ?~)
|
||||
, singletonMap "as-state" $ FilterProjected (_corrProjFilterAuthorshipStatementState <>~)
|
||||
]
|
||||
dbtFilterUI = fromMaybe mempty dbtFilterUI'
|
||||
dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI' }
|
||||
@ -742,31 +779,41 @@ postCorrectionsR = do
|
||||
getCCorrectionsR, postCCorrectionsR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
|
||||
getCCorrectionsR = postCCorrectionsR
|
||||
postCCorrectionsR tid ssh csh = do
|
||||
Entity cid _ <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
(Entity cid _, doSubmissionGroups, doAuthorshipStatements) <- runDB $ do
|
||||
course@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
doSubmissionGroups <- exists [SubmissionGroupCourse ==. cid]
|
||||
doAuthorshipStatements <- runConduit $
|
||||
(E.selectSource . E.from $ \sheet -> sheet <$ E.where_ (sheet E.^. SheetCourse E.==. E.val cid))
|
||||
.| C.mapM getSheetAuthorshipStatement
|
||||
.| C.map (is _Just)
|
||||
.| C.or
|
||||
return (course, doSubmissionGroups, doAuthorshipStatements)
|
||||
let whereClause :: CorrectionTableWhere
|
||||
whereClause = courseIs cid
|
||||
colonnade = mconcat -- should match getSSubsR for consistent UX
|
||||
[ colSelect
|
||||
, colSheet
|
||||
, colSMatrikel
|
||||
, colSubmittors
|
||||
, colSGroups
|
||||
, colSubmissionLink
|
||||
, colLastEdit
|
||||
, colRating
|
||||
, colRated
|
||||
, colCorrector
|
||||
, colAssigned
|
||||
colonnade = mconcat $ catMaybes -- should match getSSubsR for consistent UX
|
||||
[ pure colSelect
|
||||
, pure colSheet
|
||||
, pure colSMatrikel
|
||||
, pure colSubmittors
|
||||
, guardOn doSubmissionGroups colSGroups
|
||||
, pure colSubmissionLink
|
||||
, pure colLastEdit
|
||||
, guardOn doAuthorshipStatements colAuthorshipStatementState
|
||||
, pure colRating
|
||||
, pure colRated
|
||||
, pure colCorrector
|
||||
, pure colAssigned
|
||||
] -- Continue here
|
||||
filterUI = Just $ mconcat
|
||||
[ filterUIUserNameEmail
|
||||
[ filterUISheetSearch
|
||||
, filterUIUserNameEmail
|
||||
, filterUIUserMatrikelnummer
|
||||
, filterUIPseudonym
|
||||
, filterUISheetSearch
|
||||
, filterUISubmissionGroup
|
||||
, filterUIAuthorshipStatementState
|
||||
, filterUICorrectorNameEmail
|
||||
, filterUIIsAssigned
|
||||
, filterUIIsRated
|
||||
, filterUISubmissionGroup
|
||||
, filterUISubmission
|
||||
]
|
||||
psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway
|
||||
@ -779,28 +826,35 @@ postCCorrectionsR tid ssh csh = do
|
||||
getSSubsR, postSSubsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
|
||||
getSSubsR = postSSubsR
|
||||
postSSubsR tid ssh csh shn = do
|
||||
shid <- runDB $ fetchSheetId tid ssh csh shn
|
||||
(shid, doSubmissionGroups, doAuthorshipStatements) <- runDB $ do
|
||||
sheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn
|
||||
doSubmissionGroups <- exists [SubmissionGroupCourse ==. sheetCourse]
|
||||
doAuthorshipStatements <- is _Just <$> getSheetAuthorshipStatement sheet
|
||||
return (shid, doSubmissionGroups, doAuthorshipStatements)
|
||||
let whereClause :: CorrectionTableWhere
|
||||
whereClause = sheetIs shid
|
||||
colonnade = mconcat -- should match getCCorrectionsR for consistent UX
|
||||
[ colSelect
|
||||
, colSMatrikel
|
||||
, colSubmittors
|
||||
, colSubmissionLink
|
||||
, colLastEdit
|
||||
, colRating
|
||||
, colRated
|
||||
, colCorrector
|
||||
, colAssigned
|
||||
colonnade = mconcat $ catMaybes -- should match getCCorrectionsR for consistent UX
|
||||
[ pure colSelect
|
||||
, pure colSMatrikel
|
||||
, pure colSubmittors
|
||||
, guardOn doSubmissionGroups colSGroups
|
||||
, pure colSubmissionLink
|
||||
, pure colLastEdit
|
||||
, guardOn doAuthorshipStatements colAuthorshipStatementState
|
||||
, pure colRating
|
||||
, pure colRated
|
||||
, pure colCorrector
|
||||
, pure colAssigned
|
||||
]
|
||||
filterUI = Just $ mconcat
|
||||
[ filterUIUserNameEmail
|
||||
, filterUIUserMatrikelnummer
|
||||
, filterUIPseudonym
|
||||
, filterUISubmissionGroup
|
||||
, filterUIAuthorshipStatementState
|
||||
, filterUICorrectorNameEmail
|
||||
, filterUIIsAssigned
|
||||
, filterUIIsRated
|
||||
, filterUISubmissionGroup
|
||||
, filterUISubmission
|
||||
]
|
||||
psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway
|
||||
|
||||
@ -11,6 +11,8 @@ module Handler.Utils.Submission
|
||||
, submissionMatchesSheet
|
||||
, submissionDeleteRoute
|
||||
, correctionInvisibleWidget
|
||||
, AuthorshipStatementSubmissionState(..)
|
||||
, getUserAuthorshipStatement, getSubmissionAuthorshipStatement
|
||||
) where
|
||||
|
||||
import Import hiding (joinPath)
|
||||
@ -36,6 +38,7 @@ import Handler.Utils
|
||||
import qualified Handler.Utils.Rating as Rating (extractRatings)
|
||||
import Handler.Utils.Delete
|
||||
|
||||
import Database.Persist.Sql (SqlBackendCanRead)
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
import qualified Database.Esqueleto.Utils.TH as E
|
||||
|
||||
@ -976,3 +979,58 @@ correctionInvisibleWidget tid ssh csh shn cID (Entity subId sub) = runMaybeT $ d
|
||||
tellPoint CorrectionInvisibleExamUnfinished
|
||||
|
||||
return $ notification NotificationBroad =<< messageIconWidget Warning IconInvisible $(widgetFile "submission-correction-invisible")
|
||||
|
||||
|
||||
data AuthorshipStatementSubmissionState
|
||||
= ASMissing
|
||||
| ASOldStatement
|
||||
| ASExists
|
||||
deriving (Eq, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
deriving stock instance Ord AuthorshipStatementSubmissionState -- ^ Larger roughly encodes better; summaries are taken with `max`
|
||||
|
||||
nullaryPathPiece ''AuthorshipStatementSubmissionState $ camelToPathPiece' 1
|
||||
|
||||
embedRenderMessage ''UniWorX ''AuthorshipStatementSubmissionState $ concat . ("SubmissionAuthorshipStatementState" :) . drop 1 . splitCamel
|
||||
|
||||
|
||||
getUserAuthorshipStatement :: ( MonadResource m
|
||||
, IsSqlBackend backend, SqlBackendCanRead backend
|
||||
)
|
||||
=> Maybe (Entity AuthorshipStatementDefinition) -- ^ Currently expected authorship statement; see `getSheetAuthorshipStatement`
|
||||
-> SubmissionId
|
||||
-> UserId
|
||||
-> ReaderT backend m AuthorshipStatementSubmissionState
|
||||
getUserAuthorshipStatement mASDefinition subId uid = runConduit $
|
||||
getStmts
|
||||
.| fmap toRes (execWriterC . C.mapM_ $ tell . toPoint)
|
||||
where
|
||||
getStmts = E.selectSource . E.from $ \authorshipStatementSubmission -> do
|
||||
E.where_ $ authorshipStatementSubmission E.^. AuthorshipStatementSubmissionSubmission E.==. E.val subId
|
||||
E.&&. authorshipStatementSubmission E.^. AuthorshipStatementSubmissionUser E.==. E.val uid
|
||||
return authorshipStatementSubmission
|
||||
toPoint :: Entity AuthorshipStatementSubmission -> Maybe Any
|
||||
toPoint (Entity _ AuthorshipStatementSubmission{..}) = Just . Any $ fmap entityKey mASDefinition == Just authorshipStatementSubmissionStatement
|
||||
toRes :: Maybe Any -> AuthorshipStatementSubmissionState
|
||||
toRes = \case
|
||||
Just (Any True) -> ASExists
|
||||
Just (Any False) -> ASOldStatement
|
||||
Nothing -> ASMissing
|
||||
|
||||
getSubmissionAuthorshipStatement :: ( MonadResource m
|
||||
, IsSqlBackend backend, SqlBackendCanRead backend
|
||||
)
|
||||
=> Maybe (Entity AuthorshipStatementDefinition) -- ^ Currently expected authorship statement; see `getSheetAuthorshipStatement`
|
||||
-> SubmissionId
|
||||
-> ReaderT backend m AuthorshipStatementSubmissionState
|
||||
getSubmissionAuthorshipStatement mASDefinition subId = fmap (fromMaybe ASMissing) . runConduit $
|
||||
sourceSubmissionUsers
|
||||
.| C.map E.unValue
|
||||
.| C.mapM getUserAuthorshipStatement'
|
||||
.| C.maximum
|
||||
where
|
||||
getUserAuthorshipStatement' = getUserAuthorshipStatement mASDefinition subId
|
||||
sourceSubmissionUsers = E.selectSource . E.from $ \submissionUser -> do
|
||||
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val subId
|
||||
return $ submissionUser E.^. SubmissionUserUser
|
||||
|
||||
Loading…
Reference in New Issue
Block a user