diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index c998f0c9e..19ba3fb20 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -2,7 +2,6 @@ default: image: name: fpco/stack-build:lts-13.21 cache: - key: "${CI_COMMIT_REF_SLUG}" paths: - node_modules - .stack @@ -216,7 +215,7 @@ yesod:test: deploy:uniworx4: stage: deploy script: - - ssh root@uniworx4.ifi.lmu.de =4.9.1.0 && <5 diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 2cdfc69d2..b9cc734bb 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -19,6 +19,7 @@ module Database.Esqueleto.Utils , sha256 , maybe , SqlProject(..) + , (->.) , module Database.Esqueleto.Utils.TH ) where @@ -246,3 +247,6 @@ instance (PersistEntity val, PersistField typ) => SqlProject val typ (E.Entity v instance (PersistEntity val, PersistField typ) => SqlProject val typ (Maybe (E.Entity val)) (Maybe typ) where sqlProject = (E.?.) unSqlProject _ _ = Just + +(->.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value b) +(->.) expr t = E.unsafeSqlBinOp "->" expr $ E.val t diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index da2e47096..8a39796fc 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -217,6 +217,9 @@ colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ for _other -> over (_1.mapped) (_2 .~) . over _2 fvInput <$> mopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fsUniq mkUnique "points") (Just submissionRatingPoints) ) +colMaxPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData))) +colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgSheetType) $ i18nCell . (\DBRow{ dbrOutput=(_, Entity _ Sheet{sheetType}, _, _, _, _) } -> sheetType) + colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData))) colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ fmap (cellAttrs <>~ [("style","width:60%")]) $ formCell id (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId) @@ -276,6 +279,13 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d , ( "rating" , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints ) + , ( "sheet-type" + , SortColumns $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> + [ SomeExprValue ((sheet E.^. SheetType) E.->. "type" :: E.SqlExpr (E.Value Value)) + , SomeExprValue (((sheet E.^. SheetType) E.->. "grading" :: E.SqlExpr (E.Value Value)) E.->. "max" :: E.SqlExpr (E.Value Value)) + , SomeExprValue (((sheet E.^. SheetType) E.->. "grading" :: E.SqlExpr (E.Value Value)) E.->. "passing" :: E.SqlExpr (E.Value Value)) + ] + ) , ( "israted" , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> E.not_ . E.isNothing $ submission E.^. SubmissionRatingTime ) @@ -369,11 +379,22 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d E.where_ $ (\f -> f user $ Set.singleton needle) $ E.mkContainsFilter (E.^. UserMatrikelnummer) ) - -- , ( "pseudonym" - -- , FilterColumn $ E.mkExistsFilter $ \table needle -> E.from $ \(pseudonym) -> do - -- E.where_ $ querySheet table E.^. SheetId E.==. pseudonym E.^. SheetPseudonymSheet - -- E.where_ $ E.mkContainsFilter -- DB only stores Pseudonym == Word24. Conversion not possible in DB. - -- ) + , ( "rating-visible" + , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) criterion -> case getLast (criterion :: Last Bool) of + Nothing -> E.val True :: E.SqlExpr (E.Value Bool) + Just True -> E.isJust $ submission E.^. SubmissionRatingTime + Just False-> E.isNothing $ submission E.^. SubmissionRatingTime + ) + , ( "rating" + , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) pts -> if + | Set.null pts -> E.val True :: E.SqlExpr (E.Value Bool) + | otherwise -> E.maybe (E.val False :: E.SqlExpr (E.Value Bool)) (\p -> p `E.in_` E.valList (Set.toList pts)) (submission E.^. SubmissionRatingPoints) + ) + , ( "comment" + , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) comm -> case getLast (comm :: Last Text) of + Nothing -> E.val True :: E.SqlExpr (E.Value Bool) + Just needle -> E.maybe (E.val False :: E.SqlExpr (E.Value Bool)) (E.isInfixOf $ E.val needle) (submission E.^. SubmissionRatingComment) + ) ] , dbtFilterUI = fromMaybe mempty dbtFilterUI , dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (\_ -> defaultDBSFilterLayout) dbtFilterUI } @@ -983,7 +1004,8 @@ postCorrectionsCreateR = do , formEncoding = pseudonymEncoding } - defaultLayout + siteLayoutMsg MsgCorrCreate $ do + setTitleI MsgCorrCreate $(widgetFile "corrections-create") where partitionEithers' :: [[Either a b]] -> ([[b]], [a]) @@ -1013,8 +1035,28 @@ postCorrectionsGradeR = do , colRated , colRatedField , colPointsField + , colMaxPointsField , colCommentField ] -- Continue here + filterUI = Just $ \mPrev -> mconcat + [ prismAForm (singletonFilter "course" ) mPrev $ aopt (lift `hoistField` selectField courseOptions) (fslI MsgCourse) + , prismAForm (singletonFilter "term" ) mPrev $ aopt (lift `hoistField` selectField termOptions) (fslI MsgTerm) + , prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectField schoolOptions) (fslI MsgCourseSchool) + , Map.singleton "sheet-search" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev))) + , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingTime) + , prismAForm (singletonFilter "rating-visible" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingDone) + , prismAForm (singletonFilter "rating" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` pointsField) (fslI MsgColumnRatingPoints) + , Map.singleton "comment" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgRatingComment) (Just <$> listToMaybe =<< (Map.lookup "comment" =<< mPrev)) + ] + courseOptions = runDB $ do + courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand) + optionsPairs $ map (id &&& id) $ nub $ map (CI.original . courseShorthand . entityVal) courses + termOptions = runDB $ do + courses <- selectList [] [Asc CourseTerm] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand) + optionsPairs $ map (id &&& id) $ nub $ map (termToText . unTermKey . courseTerm . entityVal) courses + schoolOptions = runDB $ do + courses <- selectList [] [Asc CourseSchool] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand) + optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses psValidator = def & 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) @@ -1023,7 +1065,7 @@ postCorrectionsGradeR = do void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True return i - (fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns mempty psValidator dbtProj' $ def + (fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns filterUI psValidator dbtProj' $ def { dbParamsFormAction = Just $ SomeRoute CorrectionsGradeR } @@ -1048,7 +1090,8 @@ postCorrectionsGradeR = do content = Right $(widgetFile "messages/correctionsUploaded") unless (null subs') $ addMessageModal Success trigger content - defaultLayout $ + siteLayoutMsg MsgCorrectionsGrade $ do + setTitleI MsgCorrectionsGrade $(widgetFile "corrections-grade")