From 3b739f751d195063665430fc144169e998c8fa55 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 14 Jan 2020 17:04:49 +0100 Subject: [PATCH] feat: external exams in exam office exams table --- src/Database/Esqueleto/Utils.hs | 5 +- src/Handler/ExamOffice/Exams.hs | 148 +++++++++++++++++--------- src/Handler/Utils/Table/Columns.hs | 25 +++++ src/Handler/Utils/Table/Pagination.hs | 45 ++++++-- src/Utils.hs | 12 ++- src/Utils/Lens.hs | 1 + src/Utils/Lens/TH.hs | 1 - 7 files changed, 170 insertions(+), 67 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 5eae4b916..8b304ea99 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -17,7 +17,7 @@ module Database.Esqueleto.Utils , selectExists , SqlHashable , sha256 - , maybe + , maybe, unsafeCoalesce , SqlProject(..) , (->.) , fromSqlKey @@ -236,6 +236,9 @@ maybe onNothing onJust val = E.case_ ] (E.else_ onNothing) +unsafeCoalesce :: E.PersistField a => [E.SqlExpr (E.Value (Maybe a))] -> E.SqlExpr (E.Value a) +unsafeCoalesce = E.veryUnsafeCoerceSqlExprValue . E.coalesce + class (PersistEntity entity, PersistField value) => SqlProject entity value entity' value' | entity value entity' -> value', entity value value' -> entity' where sqlProject :: E.SqlExpr entity' -> EntityField entity value -> E.SqlExpr (E.Value value') diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index ba3a8f68e..67e15438c 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -8,6 +8,7 @@ import Import import Handler.Utils import qualified Handler.Utils.ExamOffice.Exam as Exam +import qualified Handler.Utils.ExamOffice.ExternalExam as ExternalExam import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E @@ -15,60 +16,81 @@ import qualified Database.Esqueleto.Utils as E import qualified Colonnade -type ExamsTableExpr = E.SqlExpr (Entity Exam) - `E.InnerJoin` E.SqlExpr (Entity Course) +type ExamsTableExpr = ( E.SqlExpr (Maybe (Entity Exam)) + `E.InnerJoin` E.SqlExpr (Maybe (Entity Course)) + ) + `E.FullOuterJoin` E.SqlExpr (Maybe (Entity ExternalExam)) -type ExamsTableData = DBRow ( Entity Exam - , Entity Course +type ExamsTableData = DBRow ( Either (Entity ExternalExam) (Entity Exam, Entity Course) , Natural, Natural ) -queryExam :: Getter ExamsTableExpr (E.SqlExpr (Entity Exam)) -queryExam = to $(E.sqlIJproj 2 1) +queryExam :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity Exam))) +queryExam = to $ $(E.sqlIJproj 2 1) . $(E.sqlFOJproj 2 1) -queryCourse :: Getter ExamsTableExpr (E.SqlExpr (Entity Course)) -queryCourse = to $(E.sqlIJproj 2 2) +queryCourse :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity Course))) +queryCourse = to $ $(E.sqlIJproj 2 2) . $(E.sqlFOJproj 2 1) + +queryExternalExam :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity ExternalExam))) +queryExternalExam = to $(E.sqlFOJproj 2 2) querySynchronised :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Natural)) querySynchronised office = to . runReader $ do - exam <- view queryExam + exam' <- view queryExam + externalExam' <- view queryExternalExam let - synchronised = E.subSelectCount . E.from $ \examResult -> do - E.where_ $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId + examSynchronised examId = E.subSelectCount . E.from $ \examResult -> do + E.where_ $ examResult E.^. ExamResultExam E.==. examId E.where_ $ Exam.examOfficeExamResultAuth office examResult E.where_ $ Exam.resultIsSynced office examResult - return synchronised + externalExamSynchronised externalExamId = E.subSelectCount . E.from $ \externalExamResult -> do + E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. externalExamId + E.where_ $ ExternalExam.examOfficeExternalExamResultAuth office externalExamResult + E.where_ $ ExternalExam.resultIsSynced office externalExamResult + return $ E.maybe (E.val 0) examSynchronised (exam' E.?. ExamId) E.+. E.maybe (E.val 0) externalExamSynchronised (externalExam' E.?. ExternalExamId) queryResults :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Natural)) queryResults office = to . runReader $ do - exam <- view queryExam + exam' <- view queryExam + externalExam' <- view queryExternalExam let - results = E.subSelectCount . E.from $ \examResult -> do - E.where_ $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId + results examId = E.subSelectCount . E.from $ \examResult -> do + E.where_ $ examResult E.^. ExamResultExam E.==. examId E.where_ $ Exam.examOfficeExamResultAuth office examResult - return results + externalResults externalExamId = E.subSelectCount . E.from $ \externalExamResult -> do + E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. externalExamId + E.where_ $ ExternalExam.examOfficeExternalExamResultAuth office externalExamResult + return $ E.maybe (E.val 0) results (exam' E.?. ExamId) E.+. E.maybe (E.val 0) externalResults (externalExam' E.?. ExternalExamId) queryIsSynced :: UTCTime -> E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Bool)) queryIsSynced now office = to . runReader $ do - exam <- view queryExam + exam' <- view queryExam + externalExam' <- view queryExternalExam let - synchronised = E.not_ . E.exists . E.from $ \examResult -> do - E.where_ $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId + examSynchronised examId = E.not_ . E.exists . E.from $ \examResult -> do + E.where_ $ examResult E.^. ExamResultExam E.==. examId E.where_ $ Exam.examOfficeExamResultAuth office examResult E.where_ . E.not_ $ Exam.resultIsSynced office examResult - open = E.maybe E.true (E.>. E.val now) $ exam E.^. ExamClosed - return $ synchronised E.||. open + externalExamSynchronised externalExamId = E.not_ . E.exists . E.from $ \externalExamResult -> do + E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. externalExamId + E.where_ $ ExternalExam.examOfficeExternalExamResultAuth office externalExamResult + E.where_ . E.not_ $ ExternalExam.resultIsSynced office externalExamResult + open examClosed' = E.maybe E.true (E.>. E.val now) $ examClosed' + return $ E.maybe E.false examSynchronised (exam' E.?. ExamId) E.||. E.maybe E.false open (exam' E.?. ExamClosed) E.||. E.maybe E.false externalExamSynchronised (externalExam' E.?. ExternalExamId) -resultExam :: Lens' ExamsTableData (Entity Exam) -resultExam = _dbrOutput . _1 +resultExam :: Traversal' ExamsTableData (Entity Exam) +resultExam = _dbrOutput . _1 . _Right . _1 -resultCourse :: Lens' ExamsTableData (Entity Course) -resultCourse = _dbrOutput . _2 +resultCourse :: Traversal' ExamsTableData (Entity Course) +resultCourse = _dbrOutput . _1 . _Right . _2 + +resultExternalExam :: Traversal' ExamsTableData (Entity ExternalExam) +resultExternalExam = _dbrOutput . _1 . _Left resultSynchronised, resultResults :: Lens' ExamsTableData Natural -resultSynchronised = _dbrOutput . _3 -resultResults = _dbrOutput . _4 +resultSynchronised = _dbrOutput . _2 +resultResults = _dbrOutput . _3 resultIsSynced :: Getter ExamsTableData Bool resultIsSynced = to $ (>=) <$> view resultSynchronised <*> view resultResults @@ -90,6 +112,10 @@ getEOExamsR = do courseLink :: Course -> SomeRoute UniWorX courseLink Course{..} = SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR + + externalExamLink :: ExternalExam -> SomeRoute UniWorX + externalExamLink ExternalExam{..} + = SomeRoute $ EExamR externalExamTerm externalExamSchool externalExamCourseName externalExamExamName EEGradesR querySynchronised' = querySynchronised $ E.val uid queryResults' = queryResults $ E.val uid @@ -100,34 +126,48 @@ getEOExamsR = do dbtSQLQuery = runReaderT $ do exam <- view queryExam course <- view queryCourse + externalExam <- view queryExternalExam synchronised <- view querySynchronised' results <- view queryResults' lift $ do - E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId + E.on E.false + E.on $ exam E.?. ExamCourse E.==. course E.?. CourseId E.where_ $ results E.>. E.val 0 + E.where_ $ (E.not_ (E.isNothing $ exam E.?. ExamId) E.&&. E.not_ (E.isNothing $ course E.?. CourseId) E.&&. E.isNothing (externalExam E.?. ExternalExamId)) + E.||. ( E.isNothing (exam E.?. ExamId) E.&&. E.isNothing (course E.?. CourseId) E.&&. E.not_ (E.isNothing $ externalExam E.?. ExternalExamId)) - return (exam, course, synchronised, results) - dbtRowKey = views queryExam (E.^. ExamId) + return (exam, course, externalExam, synchronised, results) + dbtRowKey = views ($(multifocusG 2) queryExam queryExternalExam) (bimap (E.?. ExamId) (E.?. ExternalExamId)) dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) ExamsTableData dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do - exam <- view $ _1 . _entityVal - course <- view $ _2 . _entityVal + exam <- view _1 + course <- view _2 + externalExam <- view _3 - guard =<< hasReadAccessTo (urlRoute $ examLink course exam) + case (exam, course, externalExam) of + (Just exam', Just course', Nothing) -> do + guard =<< hasReadAccessTo (urlRoute $ examLink (entityVal course') (entityVal exam')) - (,,,) - <$> view _1 <*> view _2 <*> view (_3 . _Value) <*> view (_4 . _Value) + (,,) + <$> pure (Right (exam', course')) <*> view (_4 . _Value) <*> view (_5 . _Value) + (Nothing, Nothing, Just externalExam') -> do + guard =<< hasReadAccessTo (urlRoute $ externalExamLink (entityVal externalExam')) + + (,,) + <$> pure (Left externalExam') <*> view (_4 . _Value) <*> view (_5 . _Value) + _other -> return $ error "Got exam & externalExam in same result" colSynced = Colonnade.singleton (fromSortable . Sortable (Just "synced") $ i18nCell MsgExamSynchronised) $ \x -> flip runReader x $ do - Entity _ Exam{examClosed} <- view resultExam + mExam <- preview resultExam if - | NTop examClosed > NTop (Just now) + | Just (Entity _ Exam{examClosed}) <- mExam + , NTop examClosed > NTop (Just now) -> return . cell $ toWidget iconNew | otherwise -> do @@ -151,26 +191,28 @@ getEOExamsR = do dbtColonnade :: Colonnade Sortable _ _ dbtColonnade = mconcat [ colSynced - , anchorColonnade (views ($(multifocusG 2) (resultCourse . _entityVal) (resultExam . _entityVal)) (uncurry examLink)) - $ colExamName (resultExam . _entityVal . _examName) - , colExamTime (resultExam . _entityVal . $(multifocusG 2) _examStart _examEnd) - , colExamFinishedOffice (resultExam . _entityVal . _examFinished) - , colExamClosed (resultExam . _entityVal . _examClosed) - , anchorColonnade (views (resultCourse . _entityVal) courseLink) - $ colCourseName (resultCourse . _entityVal . _courseName) - , colSchool (resultCourse . _entityVal . _courseSchool) - , colTermShort (resultCourse . _entityVal . _courseTerm) + , maybeAnchorColonnade ( runMaybeT $ mpreview ($(multifocusG 2) (pre $ resultCourse . _entityVal) (pre $ resultExam . _entityVal) . to (uncurry $ liftA2 examLink) . _Just) + <|> mpreviews (resultExternalExam . _entityVal) externalExamLink + ) + $ emptyOpticColonnade (resultExam . _entityVal . _examName <> resultExternalExam . _entityVal . _externalExamExamName) colExamName + , emptyOpticColonnade (resultExam . _entityVal . $(multifocusG 2) _examStart _examEnd) colExamTime + , emptyOpticColonnade (resultExam . _entityVal . _examFinished) colExamFinishedOffice + , emptyOpticColonnade (resultExam . _entityVal . _examClosed) colExamClosed + , maybeAnchorColonnade (previews (resultCourse . _entityVal) courseLink) + $ emptyOpticColonnade (resultCourse . _entityVal . _courseName <> resultExternalExam . _entityVal . _externalExamCourseName) colCourseName + , emptyOpticColonnade (resultCourse . _entityVal . _courseSchool <> resultExternalExam . _entityVal . _externalExamSchool) colSchool + , emptyOpticColonnade (resultCourse . _entityVal . _courseTerm <> resultExternalExam . _entityVal . _externalExamTerm) colTermShort ] dbtSorting = mconcat [ singletonMap "synced" . SortColumn $ (E./.) <$> view querySynchronised' <*> view queryResults' , singletonMap "is-synced" . SortColumn $ view queryIsSynced' - , sortExamName (queryExam . to (E.^. ExamName)) - , sortExamTime (queryExam . $(multifocusG 2) (to (E.^. ExamStart)) (to (E.^. ExamEnd))) - , sortExamFinished (queryExam . to (E.^. ExamFinished)) - , sortExamClosed (queryExam . to (E.^. ExamClosed)) - , sortCourseName (queryCourse . to (E.^. CourseName)) - , sortSchool (queryCourse . to (E.^. CourseSchool)) - , sortTerm (queryCourse . to (E.^. CourseTerm)) + , sortExamName (to $ E.unsafeCoalesce . sequence [views queryExam (E.?. ExamName), views queryExternalExam (E.?. ExternalExamExamName)]) + , sortExamTime (queryExam . $(multifocusG 2) (to $ E.joinV . (E.?. ExamStart)) (to $ E.joinV . (E.?. ExamEnd))) + , sortExamFinished (queryExam . to (E.joinV . (E.?. ExamFinished))) + , sortExamClosed (queryExam . to (E.joinV . (E.?. ExamClosed))) + , sortCourseName (to $ E.unsafeCoalesce . sequence [views queryCourse (E.?. CourseName), views queryExternalExam (E.?. ExternalExamCourseName)]) + , sortSchool (to $ E.unsafeCoalesce . sequence [views queryCourse (E.?. CourseSchool), views queryExternalExam (E.?. ExternalExamSchool)]) + , sortTerm (to $ E.unsafeCoalesce . sequence [views queryCourse (E.?. CourseTerm), views queryExternalExam (E.?. ExternalExamTerm)]) ] dbtFilter = mconcat diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 150b3ffcd..c1e768f4b 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -840,6 +840,31 @@ anchorColonnadeM mkUrl = imapColonnade anchorColonnade' anchorColonnade' inp (view dbCell -> (attrs, act)) = review dbCell . (attrs,) $ view (dbCell . _2) . anchorCellM (mkUrl inp) =<< act +maybeAnchorColonnade :: forall h r' m a url. + ( HasRoute UniWorX url + , IsDBTable m a + , HandlerSite m ~ UniWorX + ) + => (r' -> Maybe url) + -> Colonnade h r' (DBCell m a) + -> Colonnade h r' (DBCell m a) +maybeAnchorColonnade = maybeAnchorColonnadeM . (hoistMaybe .) + +maybeAnchorColonnadeM :: forall h r' m a url. + ( HasRoute UniWorX url + , IsDBTable m a + , HandlerSite m ~ UniWorX + ) + => (r' -> MaybeT (WidgetFor UniWorX) url) + -> Colonnade h r' (DBCell m a) + -> Colonnade h r' (DBCell m a) +maybeAnchorColonnadeM mkUrl = imapColonnade anchorColonnade' + where + anchorColonnade' :: r' -> DBCell m a -> DBCell m a + anchorColonnade' inp (view dbCell -> (attrs, act)) = review dbCell . (attrs,) $ + view (dbCell . _2) . maybeAnchorCellM (mkUrl inp) =<< act + + emptyOpticColonnade :: forall h r' focus c. ( Monoid c ) diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 06164debb..53184935c 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -33,6 +33,7 @@ module Handler.Utils.Table.Pagination , cell, textCell, stringCell, i18nCell , anchorCell, anchorCell', anchorCellM, anchorCellM' , linkEitherCell, linkEitherCellM, linkEitherCellM' + , maybeAnchorCellM, maybeAnchorCellM', maybeLinkEitherCellM' , cellTooltip , listCell , formCell, DBFormResult(..), getDBFormResult @@ -93,6 +94,8 @@ import Data.Ratio ((%)) import Data.List (elemIndex) +import Data.Maybe (fromJust) + import Data.Aeson (Options(..), SumEncoding(..), defaultOptions) import Data.Aeson.Text import Data.Aeson.TH (deriveJSON) @@ -1300,6 +1303,12 @@ anchorCellM routeM widget = anchorCellM' routeM id (const widget) anchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a anchorCellM' xM x2route x2widget = linkEitherCellM' xM x2route (x2widget, x2widget) +maybeAnchorCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => MaybeT (WidgetFor UniWorX) url -> wgt -> DBCell m a +maybeAnchorCellM routeM widget = maybeAnchorCellM' routeM id (const widget) + +maybeAnchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => MaybeT (WidgetFor UniWorX) x -> (x -> url) -> (Maybe x -> wgt) -> DBCell m a +maybeAnchorCellM' xM x2route x2widget = maybeLinkEitherCellM' xM x2route (x2widget . Just, x2widget) + -- | Variant of `anchorCell` that displays different widgets depending whether the route is authorized for current user linkEitherCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, ToWidget UniWorX wgt', IsDBTable m a) => url -> (wgt, wgt') -> DBCell m a linkEitherCell = linkEitherCellM . return @@ -1314,17 +1323,31 @@ linkEitherCellM' :: forall m url wgt wgt' a x. , IsDBTable m a ) => WidgetFor UniWorX x -> (x -> url) -> (x -> wgt, x -> wgt') -> DBCell m a -linkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ do - x <- xM - let route = x2route x - widget, widgetUnauth :: Widget - widget = toWidget $ x2widgetAuth x - widgetUnauth = toWidget $ x2widgetUnauth x - authResult <- liftHandler $ isAuthorized (urlRoute route) False - linkUrl <- toTextUrl route - case authResult of - Authorized -> $(widgetFile "table/cell/link") -- show allowed link - _otherwise -> widgetUnauth -- show alternative widget +linkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = maybeLinkEitherCellM' (lift xM) x2route (x2widgetAuth, x2widgetUnauth . fromJust) + +maybeLinkEitherCellM' :: forall m url wgt wgt' a x. + ( HasRoute UniWorX url + , ToWidget UniWorX wgt + , ToWidget UniWorX wgt' + , IsDBTable m a + ) + => MaybeT (WidgetFor UniWorX) x -> (x -> url) -> (x -> wgt, Maybe x -> wgt') -> DBCell m a +maybeLinkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ do + x' <- runMaybeT xM + case x' of + Just x -> do + let route = x2route x + widget, widgetUnauth :: Widget + widget = toWidget $ x2widgetAuth x + widgetUnauth = toWidget . x2widgetUnauth $ Just x + authResult <- liftHandler $ isAuthorized (urlRoute route) False + linkUrl <- toTextUrl route + case authResult of + Authorized -> $(widgetFile "table/cell/link") -- show allowed link + _otherwise -> widgetUnauth -- show alternative widget + _otherwise -> do + toWidget $ x2widgetUnauth Nothing + diff --git a/src/Utils.hs b/src/Utils.hs index dd9473692..f924d3141 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -8,7 +8,7 @@ import ClassyPrelude.Yesod hiding (foldlM, Proxy, handle, catch) -- import Data.Double.Conversion.Text -- faster implementation for textPercent? import qualified Data.Foldable as Fold import Data.Foldable as Utils (foldlM, foldrM) -import Data.Monoid (Sum(..)) +import Data.Monoid (First, Sum(..)) import Data.Proxy import Data.CaseInsensitive (CI) @@ -988,3 +988,13 @@ unstableSortOn = unstableSortBy . comparing unstableSort :: (MonadRandom m, Ord a) => [a] -> m [a] unstableSort = unstableSortBy compare + +---------- +-- Lens -- +---------- + +mpreview :: (MonadPlus m, MonadReader s m) => Getting (First a) s a -> m a +mpreview = hoistMaybe <=< preview + +mpreviews :: (MonadPlus m, MonadReader s m) => Getting (First b) s a -> (a -> b) -> m b +mpreviews a f = hoistMaybe =<< previews a f diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 8a2de3fc8..72012f265 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -221,6 +221,7 @@ makeLenses_ ''Tutorial makeLenses_ ''SessionFile +makeLenses_ ''ExternalExam makeLenses_ ''ExternalExamOfficeSchool makeLenses_ ''ExternalExamStaff makeLenses_ ''ExternalExamResult diff --git a/src/Utils/Lens/TH.hs b/src/Utils/Lens/TH.hs index 0042fb308..c4a2f1a82 100644 --- a/src/Utils/Lens/TH.hs +++ b/src/Utils/Lens/TH.hs @@ -87,7 +87,6 @@ multifocusL = multifocusOptic (\s a -> [t|Lens' $(s) $(a)|]) (\doGet doSet -> [e|lens $(doGet) $(doSet)|]) - multifocusOptic :: _ -> _ -> _ -> _ -> Natural -> ExpQ multifocusOptic _ _ _ _ 0 = [e|united|] multifocusOptic doClone _ _ _ 1 = doClone