feat: external exams in exam office exams table

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')

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

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
                        )

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
+
 
 
 

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

src/Utils/Lens.hs

@@ -221,6 +221,7 @@ makeLenses_ ''Tutorial
 
 makeLenses_ ''SessionFile
   
+makeLenses_ ''ExternalExam
 makeLenses_ ''ExternalExamOfficeSchool
 makeLenses_ ''ExternalExamStaff
 makeLenses_ ''ExternalExamResult

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