Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

CHANGELOG.md

@@ -2,6 +2,24 @@
 
 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
 
+### [4.12.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.12.0...v4.12.1) (2019-08-06)
+
+
+### Bug Fixes
+
+* **exams:** allow occurrences after exam end ([3d63b35](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/3d63b35))
+
+
+
+## [4.12.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.11.0...v4.12.0) (2019-08-06)
+
+
+### Features
+
+* **exams:** improve immediate exam table on home page ([93e718f](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/93e718f))
+
+
+
 ## [4.11.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.10.0...v4.11.0) (2019-08-06)
 
 

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "4.11.0",
+  "version": "4.12.1",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "4.11.0",
+  "version": "4.12.1",
   "description": "",
   "keywords": [],
   "author": "",

package.yaml

@@ -1,5 +1,5 @@
 name:    uniworx
-version: 4.11.0
+version: 4.12.1
 
 dependencies:
   # Due to a bug in GHC 8.0.1, we block its usage

src/Foundation.hs

@@ -834,7 +834,7 @@ tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of
           || NTop allocationRegisterByStaffFrom >= NTop (Just now)
           -> unauthorizedI MsgUnauthorizedAllocatedCourseDelete
       _other -> return Authorized
-  
+
   r -> $unsupportedAuthPredicate AuthAllocationTime r
   where
     mbAllocation tid ssh csh = $cachedHereBinary (tid, ssh, csh) . runMaybeT $ do
@@ -1805,6 +1805,14 @@ pageActions (HomeR) =
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
+  , MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuCourseNew
+      , menuItemIcon  = Just "book"
+      , menuItemRoute = SomeRoute CourseNewR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
   ,  MenuItem
       { menuItemType  = PageActionPrime
       , menuItemLabel = MsgAdminHeading
@@ -2968,7 +2976,7 @@ instance YesodAuth UniWorX where
               acceptExisting
           | otherwise
           = return res
-          
+
         excHandlers =
           [ C.Handler $ \case
               CampusUserNoResult -> do

src/Handler/Exam/Form.hs

@@ -11,18 +11,18 @@ import Import
 import Utils.Lens hiding (parts)
 
 import Handler.Exam.CorrectorInvite
-  
+
 import Handler.Utils
 import Handler.Utils.Invitations
-  
+
 import Data.Map ((!))
 import qualified Data.Set as Set
-  
+
 import qualified Database.Esqueleto as E
-  
+
 import qualified Control.Monad.State.Class as State
 import Text.Blaze.Html.Renderer.String (renderHtml)
-  
+
 
 data ExamForm = ExamForm
   { efName :: ExamName
@@ -344,9 +344,9 @@ validateExam = do
   guardValidation MsgExamClosedMustBeAfterEnd                              . fromMaybe True $ (>=) <$> efClosed <*> efEnd
 
   forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
-    guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart)
+    guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName)       $ NTop eofEnd >= NTop (Just eofStart)
     guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofName) $ NTop (Just eofStart) >= NTop efStart
-    guardValidation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofName) $ NTop eofEnd <= NTop efEnd
+    warn_Validation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofName)    $ NTop eofEnd <= NTop efEnd
 
   forM_ [ (a, b) | a <- Set.toAscList efOccurrences, b <- Set.toAscList efOccurrences, b > a ] $ \(a, b) -> do
     eofRange' <- formatTimeRange SelFormatDateTime (eofStart a) (eofEnd a)

src/Handler/Home.hs

@@ -196,24 +196,39 @@ homeUpcomingExams uid = do
     examDBTable = DBTable{..}
       where
         -- for ease of refactoring:
-        queryCourse = $(sqlIJproj 2 1)
+        queryCourse = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
-        queryExam   = $(sqlIJproj 2 2)
+        queryExam   = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
-        lensCourse  = _1
+        lensCourse     = _1
-        lensExam    = _2
+        lensExam       = _2
+        lensRegister   = _3 . _Just
+        lensOccurrence = _4 . _Just
 
-        dbtSQLQuery (course `E.InnerJoin` exam) = do
+        dbtSQLQuery ((course `E.InnerJoin` exam) `E.LeftOuterJoin` register `E.LeftOuterJoin` occurrence) = do
+          E.on $ register E.?. ExamRegistrationOccurrence E.==. E.just (occurrence E.?. ExamOccurrenceId)
+          E.on $ register E.?. ExamRegistrationExam       E.==. E.just (exam E.^. ExamId)
+                E.&&. register E.?. ExamRegistrationUser  E.==. E.just (E.val uid)
           E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
           E.where_ $ E.exists $ E.from $ \participant ->
             E.where_ $ participant E.^. CourseParticipantUser   E.==. E.val uid
               E.&&.    participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
-          let regFromJustFortnight =
+          let regToWithinFortnight = exam E.^. ExamRegisterTo    E.<=. E.just (E.val fortnight)
-                E.isJust (exam E.^. ExamRegisterFrom)
+                              E.&&.  exam E.^. ExamRegisterTo    E.>=. E.just (E.val now)
-                E.&&.     exam E.^. ExamRegisterFrom  E.<=. E.just (E.val fortnight)
+                              E.&&.  E.isNothing (register E.?. ExamRegistrationId)
-              regToJustNow =
+              startExamFortnight   = exam E.^. ExamStart         E.<=. E.just (E.val fortnight)
-                E.isJust (exam E.^. ExamEnd)
+                              E.&&.  exam E.^. ExamStart         E.>=. E.just (E.val now)
-                E.&&.     exam E.^. ExamEnd           E.>=. E.just (E.val now)
+                              E.&&.  E.isJust (register E.?. ExamRegistrationId)
-          E.where_ $ regFromJustFortnight E.&&. regToJustNow
+              startOccurFortnight  = occurrence E.?. ExamOccurrenceStart E.<=. E.just (E.val fortnight)
-          return (course, exam)
+                              E.&&.  occurrence E.?. ExamOccurrenceStart E.>=. E.just (E.val now)
+                              E.&&.  E.isJust (register E.?. ExamRegistrationId)
+              earliestOccurrence = E.sub_select $ E.from $ \occ -> do
+                               E.where_ $ occ E.^. ExamOccurrenceExam E.==. exam E.^. ExamId
+                                   E.&&.  occ E.^. ExamOccurrenceStart E.>=. E.val now
+                               return $ E.min_ $ occ E.^. ExamOccurrenceStart
+              startEarliest = E.isNothing (occurrence E.?. ExamOccurrenceId)
+                        E.&&. earliestOccurrence E.<=. E.just (E.val fortnight)
+                        -- E.&&. earliestOccurrence E.>=. E.just (E.val now)
+          E.where_ $ regToWithinFortnight E.||. startExamFortnight E.||. startOccurFortnight E.||. startEarliest
+          return (course, exam, register, occurrence)
         dbtRowKey = queryExam >>> (E.^. ExamId)
         dbtProj r@DBRow{ dbrOutput } = do
           let Entity _ Exam{..}   = view lensExam   dbrOutput
@@ -234,7 +249,12 @@ homeUpcomingExams uid = do
               indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) examName
           , sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
           , sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
-          , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
+          , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput } ->
+              if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput
+                   -> cell $ formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd
+                 | Entity _ Exam{..} <- view lensExam dbrOutput
+                 , Just start <- examStart -> cell $ formatTimeRangeW SelFormatDateTime start examEnd
+                 | otherwise -> mempty
           {- NOTE: We do not want thoughtless exam registrations, since many people click "register" and don't show up, causing logistic problems.
              Hence we force them here to click twice. Maybe add a captcha where users have to distinguish pictures showing pink elephants and course lecturers.
           , sortable Nothing mempty $ \DBRow{ dbrOutput } -> sqlCell $ do
@@ -254,14 +274,18 @@ homeUpcomingExams uid = do
                 | otherwise -> return mempty
             -}
           , sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput } -> sqlCell $ do
-              let Entity eId Exam{..} = view lensExam   dbrOutput
+              let Entity _ Exam{..} = view lensExam   dbrOutput
                   Entity _ Course{..} = view lensCourse dbrOutput
               mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True
-              isRegistered <- existsBy $ UniqueExamRegistration eId uid
+              let isRegistered = has lensRegister dbrOutput
-              let label   = bool MsgExamNotRegistered MsgExamRegistered isRegistered
+                  label   = bool MsgExamNotRegistered MsgExamRegistered isRegistered
                   examUrl = CExamR courseTerm courseSchool courseShorthand examName EShowR
               if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl
                  | otherwise   -> return [whamlet|_{label}|]
+          , sortable (toNothingS "occurrence") (i18nCell MsgExamOccurrence) $ \DBRow{ dbrOutput } ->
+              if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput
+                   -> textCell examOccurrenceRoom
+                 | otherwise -> mempty
           ]
         dbtSorting = Map.fromList
           [ ("demo-both",     SortColumn $ queryCourse &&& queryExam >>> (\(_course,exam)-> exam E.^. ExamName))

src/Utils/Form.hs

@@ -4,7 +4,7 @@
 
 module Utils.Form where
 
-import ClassyPrelude.Yesod hiding (addMessage, cons, Proxy(..), identifyForm)
+import ClassyPrelude.Yesod hiding (addMessage, addMessageI, cons, Proxy(..), identifyForm)
 import Yesod.Core.Instances ()
 import Settings
 
@@ -632,7 +632,7 @@ selectField' :: ( Eq a
 selectField' optMsg mkOpts = Field{..}
   where
     fieldEnctype = UrlEncoded
-    
+
     fieldParse []    _ = return $ Right Nothing
     fieldParse (s:_) _
       | s == ""     = return $ Right Nothing
@@ -646,7 +646,7 @@ selectField' optMsg mkOpts = Field{..}
         rendered = case val of
           Left  _ -> ""
           Right a -> maybe "" optionExternalValue . listToMaybe $ filter ((== a) . optionInternalValue) olOptions
-        
+
         isSel Nothing    = not $ rendered `elem` map optionExternalValue olOptions
         isSel (Just opt) = rendered == optionExternalValue opt
       [whamlet|
@@ -936,7 +936,7 @@ guardValidation :: ( MonadHandler m
                 => msg -- ^ Message describing violation
                 -> Bool -- ^ @False@ iff constraint is violated
                 -> FormValidator r m ()
-guardValidation msg isValid = when (not isValid) $ tellValidationError msg
+guardValidation msg isValid = unless isValid $ tellValidationError msg
 
 guardValidationM :: ( MonadHandler m
                     , RenderMessage (HandlerSite m) msg
@@ -944,6 +944,16 @@ guardValidationM :: ( MonadHandler m
                  => msg -> m Bool -> FormValidator r m ()
 guardValidationM = (. lift) . (=<<) . guardValidation
 
+-- | like `guardValidation`, but issues a warning instead
+warn_Validation :: ( MonadHandler m
+                   , RenderMessage (HandlerSite m) msg
+                   )
+                => msg -- ^ Message describing violation
+                -> Bool -- ^ @False@ iff constraint is violated
+                -> FormValidator r m ()
+warn_Validation msg isValid = unless isValid $ addMessageI Warning msg
+
+
 -----------------------
 -- Form Manipulation --
 -----------------------