feat(courses): course events

frontend/src/utils/inputs/inputs.scss

@@ -64,12 +64,6 @@
   font-weight: 600;
 }
 
-.form-group--optional {
-  .form-group-label__caption::after {
-    content: '';
-  }
-}
-
 .form-group--submit .form-group__input {
   grid-column: 2;
 }

messages/uniworx/de.msg

@@ -1107,6 +1107,8 @@ MenuSchoolList: Institute
 MenuSchoolNew: Neues Institut anlegen
 MenuCourseNewsNew: Neue Kursnachricht
 MenuCourseNewsEdit: Kursnachricht bearbeiten
+MenuCourseEventNew: Neuer Kurstermin
+MenuCourseEventEdit: Kurstermin bearbeiten
 
 AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren.
 AuthPredsActive: Aktive Authorisierungsprädikate
@@ -1245,6 +1247,7 @@ WeekDay: Wochentag
 Day: Tag
 OccurrenceStart: Beginn
 OccurrenceEnd: Ende
+OccurrenceNever: Nie
 ScheduleExists: Dieser Plan existiert bereits
 
 ScheduleExceptions: Termin-Ausnahmen
@@ -1917,3 +1920,17 @@ FavouriteVisited: Kürzlich besucht
 FavouriteParticipant: Ihre Kurse
 FavouriteManual: Favoriten
 FavouriteCurrent: Aktueller Kurs
+
+CourseEvents: Termine
+CourseEventType: Art
+CourseEventTypePlaceholder: Vorlesung, Zentralübung, ...
+CourseEventTime: Zeit
+CourseEventRoom: Regulärer Raum
+CourseEventActions: Aktionen
+CourseEventsActionEdit: Bearbeiten
+CourseEventsActionDelete: Löschen
+CourseEventsActionCreate: Neuer Termin
+CourseEventCreated: Kurstermin erfolgreich angelegt
+CourseEventEdited: Kurstermin erfolgreich editiert
+CourseEventDeleteQuestion: Wollen Sie den unten aufgeführten Termin wirklich löschen?
+CourseEventDeleted: Kurstermin erfolgreich gelöscht

models/courses.model

@@ -25,6 +25,12 @@ Course    -- Information about a single course; contained info is always visible
     TermSchoolCourseShort  term school shorthand    -- shorthand must be unique within school and semester
     TermSchoolCourseName   term school name         -- name must be unique within school and semester
     deriving Generic
+CourseEvent
+    type (CI Text)
+    course CourseId
+    room Text
+    time Occurrences
+    lastChanged UTCTime default=now()
 
 CourseAppInstructionFile
     course    CourseId

routes

@@ -187,6 +187,11 @@
     /delete                     CNDeleteR      GET POST
     !/download                  CNArchiveR     GET             !timeANDparticipant
     !/download/*FilePath        CNFileR        GET             !timeANDparticipant
+  !/events/add                  CEventsNewR    GET POST
+  /events/#CryptoUUIDCourseEvent CourseEventR:
+    /edit                       CEvEditR       GET POST
+    /delete                     CEvDeleteR     GET POST
+
 
 /subs          CorrectionsR          GET POST !corrector !lecturer
 /subs/upload   CorrectionsUploadR    GET POST !corrector !lecturer

src/CryptoID.hs

@@ -49,6 +49,7 @@ decCryptoIDs [ ''SubmissionId
              , ''CourseApplicationId
              , ''CourseId
              , ''CourseNewsId
+             , ''CourseEventId
              ]
 
 -- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission"

src/Foundation.hs

@@ -157,6 +157,7 @@ deriving instance Generic AllocationR
 deriving instance Generic SchoolR
 deriving instance Generic ExamOfficeR
 deriving instance Generic CourseNewsR
+deriving instance Generic CourseEventR
 deriving instance Generic (Route UniWorX)
 
 data RouteChildren
@@ -205,6 +206,10 @@ pattern CNewsR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews
 pattern CNewsR tid ssh csh nId ptn
   = CourseR tid ssh csh (CourseNewsR nId ptn)
   
+pattern CEventR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseEvent -> CourseEventR -> Route UniWorX
+pattern CEventR tid ssh csh nId ptn
+  = CourseR tid ssh csh (CourseEventR nId ptn)
+
 
 pluralDE :: (Eq a, Num a)
             =>    a -- ^ Count

src/Handler/Course.hs

@@ -18,6 +18,7 @@ import Handler.Course.Users as Handler.Course
 import Handler.Course.Application as Handler.Course
 import Handler.ExamOffice.Course as Handler.Course
 import Handler.Course.News as Handler.Course
+import Handler.Course.Events as Handler.Course
 
 
 getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html

src/Handler/Course/Events.hs

@@ -0,0 +1,7 @@
+module Handler.Course.Events
+  ( module Handler.Course.Events
+  ) where
+
+import Handler.Course.Events.New as Handler.Course.Events
+import Handler.Course.Events.Edit as Handler.Course.Events
+import Handler.Course.Events.Delete as Handler.Course.Events

src/Handler/Course/Events/Delete.hs

@@ -0,0 +1,50 @@
+module Handler.Course.Events.Delete
+  ( getCEvDeleteR, postCEvDeleteR
+  ) where
+
+import Import
+
+import Handler.Utils.Occurrences
+import Handler.Utils.Delete
+
+import qualified Data.Set as Set
+  
+
+getCEvDeleteR, postCEvDeleteR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseEvent -> Handler Html
+getCEvDeleteR = postCEvDeleteR
+postCEvDeleteR tid ssh csh cID = do
+  nId <- decrypt cID
+  
+  let
+    drRecords :: Set (Key CourseEvent)
+    drRecords = Set.singleton nId
+
+    drGetInfo = return
+    drUnjoin = id
+
+    drRenderRecord :: Entity CourseEvent -> DB Widget
+    drRenderRecord (Entity _ CourseEvent{..}) = return
+      [whamlet|
+        $newline never
+        #{courseEventType}
+        , #{courseEventRoom}
+        :
+        ^{occurrencesWidget courseEventTime}
+      |]
+  
+    drRecordConfirmString :: Entity CourseEvent -> DB Text
+    drRecordConfirmString _ = return ""
+  
+    drCaption, drSuccessMessage :: SomeMessage UniWorX
+    drCaption = SomeMessage MsgCourseEventDeleteQuestion
+    drSuccessMessage = SomeMessage MsgCourseEventDeleted
+  
+    drAbort, drSuccess :: SomeRoute UniWorX
+    drAbort = SomeRoute $ CourseR tid ssh csh CShowR :#: [st|event-#{toPathPiece cID}|]
+    drSuccess = SomeRoute $ CourseR tid ssh csh CShowR
+  
+    drDelete :: forall a. CourseEventId -> DB a -> DB a
+    drDelete _ = id
+  
+  deleteR DeleteRoute{..}
+

src/Handler/Course/Events/Edit.hs

@@ -0,0 +1,39 @@
+module Handler.Course.Events.Edit
+  ( getCEvEditR, postCEvEditR
+  ) where
+
+import Import
+import Handler.Utils
+  
+import Handler.Course.Events.Form
+
+
+getCEvEditR, postCEvEditR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseEvent -> Handler Html
+getCEvEditR = postCEvEditR
+postCEvEditR tid ssh csh cID = do
+  eId <- decrypt cID
+  courseEvent@CourseEvent{..} <- runDB $ get404 eId
+
+  ((eventRes, eventWgt'), eventEnctype) <- runFormPost . courseEventForm . Just $ courseEventToForm courseEvent
+
+  formResult eventRes $ \CourseEventForm{..} -> do
+    now <- liftIO getCurrentTime
+    runDB $ do
+      replace eId CourseEvent
+        { courseEventCourse
+        , courseEventType = cefType
+        , courseEventRoom = cefRoom
+        , courseEventTime = cefTime
+        , courseEventLastChanged = now
+        }
+    addMessageI Success MsgCourseEventEdited
+    redirect $ CourseR tid ssh csh CShowR :#: [st|event-#{toPathPiece cID}|]
+
+  siteLayoutMsg MsgMenuCourseEventEdit $ do
+    setTitleI MsgMenuCourseEventEdit
+
+    wrapForm eventWgt' def
+      { formAction = Just . SomeRoute $ CEventR tid ssh csh cID CEvEditR
+      , formEncoding = eventEnctype
+      }
+

src/Handler/Course/Events/Form.hs

@@ -0,0 +1,48 @@
+module Handler.Course.Events.Form
+  ( CourseEventForm(..)
+  , courseEventForm
+  , courseEventToForm
+  ) where
+
+import Import
+import Handler.Utils
+import Handler.Utils.Form.Occurrences
+
+import qualified Database.Esqueleto as E
+
+
+data CourseEventForm = CourseEventForm
+  { cefType             :: CI Text
+  , cefRoom             :: Text
+  , cefTime             :: Occurrences
+  }
+
+courseEventForm :: Maybe CourseEventForm -> Form CourseEventForm
+courseEventForm template = identifyForm FIDCourseEvent . renderWForm FormStandard $ do
+  MsgRenderer mr <- getMsgRenderer
+
+  muid <- maybeAuthId
+  existingEvents <- liftHandler . runDB $ fromMaybe [] <$> for muid
+    (\uid -> E.select . E.from $ \(lecturer `E.InnerJoin` event) -> do
+        E.on $ lecturer E.^. LecturerCourse E.==. event E.^. CourseEventCourse
+         E.&&. lecturer E.^. LecturerUser E.==. E.val uid
+        return event
+    )
+  let courseEventTypes = optionsPairs $ [ (courseEventType, courseEventType) | Entity _ CourseEvent{..} <- existingEvents ]
+      courseEventRooms = optionsPairs $ [ (courseEventRoom, courseEventRoom) | Entity _ CourseEvent{..} <- existingEvents ]
+  
+  cefType' <- wreq (textField & cfStrip & cfCI & addDatalist courseEventTypes) (fslI MsgCourseEventType & addPlaceholder (mr MsgCourseEventTypePlaceholder)) (cefType <$> template)
+  cefRoom' <- wreq (textField & cfStrip & addDatalist courseEventRooms) (fslI MsgCourseEventRoom) (cefRoom <$> template)
+  cefTime' <- aFormToWForm $ occurrencesAForm ("time" :: Text) (cefTime <$> template)
+
+  return $ CourseEventForm
+    <$> cefType'
+    <*> cefRoom'
+    <*> cefTime'
+
+courseEventToForm :: CourseEvent -> CourseEventForm
+courseEventToForm CourseEvent{..} = CourseEventForm
+  { cefType = courseEventType
+  , cefRoom = courseEventRoom
+  , cefTime = courseEventTime
+  }

src/Handler/Course/Events/New.hs

@@ -0,0 +1,38 @@
+module Handler.Course.Events.New
+  ( getCEventsNewR, postCEventsNewR
+  ) where
+
+import Import
+import Handler.Utils
+  
+import Handler.Course.Events.Form
+
+getCEventsNewR, postCEventsNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCEventsNewR = postCEventsNewR
+postCEventsNewR tid ssh csh = do
+  cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
+
+  ((eventRes, eventWgt'), eventEnctype) <- runFormPost $ courseEventForm Nothing
+
+  formResult eventRes $ \CourseEventForm{..} -> do
+    now <- liftIO getCurrentTime
+    cID <- runDB $ do
+      eId <- insert CourseEvent
+        { courseEventCourse      = cid
+        , courseEventType        = cefType
+        , courseEventRoom        = cefRoom
+        , courseEventTime        = cefTime
+        , courseEventLastChanged = now
+        }
+      encrypt eId :: DB CryptoUUIDCourseEvent
+    addMessageI Success MsgCourseEventCreated
+    redirect $ CourseR tid ssh csh CShowR :#: [st|event-#{toPathPiece cID}|]
+
+  siteLayoutMsg MsgMenuCourseEventNew $ do
+    setTitleI MsgMenuCourseEventNew
+
+    wrapForm eventWgt' def
+      { formAction = Just . SomeRoute $ CourseR tid ssh csh CEventsNewR
+      , formEncoding = eventEnctype
+      }
+

src/Handler/Course/Show.hs

@@ -26,7 +26,7 @@ import qualified Data.Conduit.List as C
 getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCShowR tid ssh csh = do
   mbAid <- maybeAuthId
-  (cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news) <- runDB . maybeT notFound $ do
+  (cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events) <- runDB . maybeT notFound $ do
     [(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)]
        <- lift . E.select . E.from $
          \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
@@ -88,7 +88,11 @@ getCShowR tid ssh csh = do
       mayEdit <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNEditR
       mayDelete <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNDeleteR
       return (cID, n, visible, files, lastEditText, mayEdit, mayDelete)
-    return (cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news)
+
+    events' <- fmap (sortOn $ courseEventTime . entityVal) . lift $ selectList [ CourseEventCourse ==. cid ] []
+    events <- mapM (\(Entity evId ev) -> (, ev) <$> encrypt evId) events'
+  
+    return (cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events)
 
   let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course
   mDereg <- traverse (formatTime SelFormatDateTime) mDereg' 
@@ -259,6 +263,7 @@ getCShowR tid ssh csh = do
         , all (notElem pathSeparator . view _2) fs
         ]
   mayCreateNews <- hasWriteAccessTo $ CourseR tid ssh csh CNewsNewR
+  mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR
 
   siteLayout (toWgt $ courseName course) $ do
     setTitleI $ prependCourseTitle tid ssh csh (""::Text)

src/Handler/Utils.hs

@@ -23,6 +23,7 @@ import Handler.Utils.ContentDisposition as Handler.Utils
 import Handler.Utils.I18n       as Handler.Utils
 import Handler.Utils.Widgets    as Handler.Utils
 import Handler.Utils.Database   as Handler.Utils
+import Handler.Utils.Occurrences as Handler.Utils
 
 import System.FilePath.Posix (takeFileName)
 

src/Handler/Utils/Form/Occurrences.hs

@@ -53,7 +53,7 @@ occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do
           newSched <- multiActionW
             (Map.fromList [ ( ScheduleKindWeekly
                             , ScheduleWeekly
-                                <$> apreq (selectField optionsFinite) (fslI MsgWeekDay & addName (nudge "occur-week-day")) Nothing
+                                <$> apreq (selectField' Nothing optionsFinite) (fslI MsgWeekDay & addName (nudge "occur-week-day")) Nothing
                                 <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart & addName (nudge "occur-start")) Nothing
                                 <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end")) Nothing
                             )

src/Handler/Utils/Occurrences.hs

@@ -0,0 +1,29 @@
+module Handler.Utils.Occurrences
+  ( occurrencesWidget
+  ) where
+
+import Import
+
+import qualified Data.Set as Set
+
+import Utils.Occurrences
+
+import Handler.Utils.DateTime
+
+
+occurrencesWidget :: Occurrences -> Widget
+occurrencesWidget (normalizeOccurrences -> Occurrences{..}) = do
+  let occurrencesScheduled' = flip map (Set.toList occurrencesScheduled) $ \case
+        ScheduleWeekly{..} -> do
+          scheduleStart' <- formatTime SelFormatTime scheduleStart
+          scheduleEnd' <- formatTime SelFormatTime scheduleEnd
+          $(widgetFile "widgets/occurrence/cell/weekly")
+      occurrencesExceptions' = flip map (Set.toList occurrencesExceptions) $ \case
+        ExceptOccur{..} -> do
+          exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart)
+          exceptEnd'   <- formatTime SelFormatTime     exceptStart
+          $(widgetFile "widgets/occurrence/cell/except-occur")
+        ExceptNoOccur{..} -> do
+          exceptTime' <- formatTime SelFormatDateTime exceptTime
+          $(widgetFile "widgets/occurrence/cell/except-no-occur")
+  $(widgetFile "widgets/occurrence/cell")

src/Handler/Utils/Table/Cells.hs

@@ -14,10 +14,7 @@ import Text.Blaze (ToMarkup(..))
 import Handler.Utils.Table.Pagination
 import Handler.Utils.DateTime
 import Handler.Utils.Widgets
-
+import Handler.Utils.Occurrences
-import Utils.Occurrences
-
-import qualified Data.Set as Set
 
 
 type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles !
@@ -269,18 +266,4 @@ correctorLoadCell sc =
   i18nCell $ sheetCorrectorLoad sc
 
 occurrencesCell :: IsDBTable m a => Occurrences -> DBCell m a
-occurrencesCell (normalizeOccurrences -> Occurrences{..}) = cell $ do
+occurrencesCell = cell . occurrencesWidget
-  let occurrencesScheduled' = flip map (Set.toList occurrencesScheduled) $ \case
-        ScheduleWeekly{..} -> do
-          scheduleStart' <- formatTime SelFormatTime scheduleStart
-          scheduleEnd' <- formatTime SelFormatTime scheduleEnd
-          $(widgetFile "widgets/occurrence/cell/weekly")
-      occurrencesExceptions' = flip map (Set.toList occurrencesExceptions) $ \case
-        ExceptOccur{..} -> do
-          exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart)
-          exceptEnd'   <- formatTime SelFormatTime     exceptStart
-          $(widgetFile "widgets/occurrence/cell/except-occur")
-        ExceptNoOccur{..} -> do
-          exceptTime' <- formatTime SelFormatDateTime exceptTime
-          $(widgetFile "widgets/occurrence/cell/except-no-occur")
-  $(widgetFile "widgets/occurrence/cell")

src/Utils/Form.hs

@@ -197,6 +197,7 @@ data FormIdentifier
   | FIDsheet
   | FIDmaterial
   | FIDCourseNews
+  | FIDCourseEvent
   | FIDsubmission
   | FIDsettings
   | FIDcorrectors

templates/course.hamlet

@@ -194,6 +194,53 @@ $#    $if NTop (Just 0) < NTop (courseCapacity course)
     <dt .deflist__dt>_{MsgCourseExams}
     <dd .deflist__dd>
       ^{examTable}
+  $if not (null events) || mayCreateEvents
+    <dt .deflist__dt>_{MsgCourseEvents}
+    <dd .deflist__dd>
+      <div .scrolltable .scrolltable--bordered>
+        <table .table .table--striped .table--hover>
+          <thead>
+            <tr .table__row .table__row--head>
+              <th .table__th>
+                _{MsgCourseEventType}
+              <th .table__th>
+                _{MsgCourseEventTime}
+              <th .table__th>
+                _{MsgCourseEventRoom}
+              $if mayCreateEvents
+                <th .table__th>
+                  _{MsgCourseEventActions}
+                  \ #{iconInvisible}
+          <tbody>
+            $forall (cID, CourseEvent{courseEventType, courseEventTime, courseEventRoom}) <- events
+              <tr .table__row ##{"event-" <> toPathPiece cID}>
+                <td .table__td>
+                  <div .table__td-content>
+                    #{courseEventType}
+                <td .table__td>
+                  <div .table__td-content>
+                    ^{occurrencesWidget courseEventTime}
+                <td .table__td>
+                  <div .table__td-content>
+                    #{courseEventRoom}
+                $if mayCreateEvents
+                  <td .table__td>
+                    <ul .list--inline .list--iconless .list--comma-separated>
+                      <li>
+                        ^{modal (i18n MsgCourseEventsActionEdit) (Left (SomeRoute (CEventR tid ssh csh cID CEvEditR)))}
+                      <li>
+                        ^{modal (i18n MsgCourseEventsActionDelete) (Left (SomeRoute (CEventR tid ssh csh cID CEvDeleteR)))}
+          $if mayCreateEvents
+            <tfoot>
+              <tr .table__row .table__row--foot>
+                <td>
+                <td>
+                <td>
+                <td .table__td>
+                  <div .table__td-content>
+                    ^{modal (i18n MsgCourseEventsActionCreate) (Left (SomeRoute (CourseR tid ssh csh CEventsNewR)))}
+          
+                  
   $if hasTutorials
     <dt .deflist__dt>_{MsgCourseTutorials}
     <dd .deflist__dd>

templates/default-layout.lucius

@@ -342,7 +342,7 @@ input[type="button"].btn-info:hover,
 
 .table--hover {
 
-  .table__row:not(.no-hover):not(.table__row--sum):not(.table__row--head):hover {
+  .table__row:not(.no-hover):not(.table__row--sum):not(.table__row--head):not(.table__row--foot):hover {
     background-color: rgba(0, 0, 0, 0.07);
   }
 }

templates/widgets/occurrence/cell.hamlet

@@ -1,12 +1,16 @@
 $newline never
-<ul .list--inline .list--iconless .list--comma-separated>
+$if not (null occurrencesScheduled)
-  $forall sched <- occurrencesScheduled'
+  <ul .list--inline .list--iconless .list--comma-separated>
-    <li>^{sched}
+    $forall sched <- occurrencesScheduled'
+      <li>^{sched}
 
 $if not (null occurrencesExceptions)
   $# <div .tooltip>
   $#   <div .tooltip__handle .tooltip__handle--danger>
   $#   <div .tooltip__content>
-      <ul>
+      <ul .list--iconless>
         $forall exc <- occurrencesExceptions'
           <li>^{exc}
+
+$if null occurrencesScheduled && null occurrencesExceptions
+  _{MsgOccurrenceNever}

templates/widgets/occurrence/cell/except-occur.hamlet

@@ -1,2 +1,5 @@
 $newline never
-_{MsgExceptionKindOccur}: #{exceptStart'}–#{exceptEnd'}
+$if not (null occurrencesScheduled')
+  _{MsgExceptionKindOccur}: #{exceptStart'}–#{exceptEnd'}
+$else
+  #{exceptStart'}–#{exceptEnd'}

test/FoundationSpec.hs

@@ -69,6 +69,10 @@ instance Arbitrary CourseNewsR where
   arbitrary = genericArbitrary
   shrink = genericShrink
   
+instance Arbitrary CourseEventR where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
 instance Arbitrary (Route UniWorX) where
   arbitrary = genericArbitrary
   shrink = genericShrink