chore(daily): improve stub #90 change DB to JSONB (WIP)

messages/uniworx/categories/school/de-de-formal.msg

@@ -40,4 +40,6 @@ SchoolAuthorshipStatementSheetDefinitionTip: Bitte in sowohl deutscher als auch
 SchoolAuthorshipStatementSheetExamDefinition: Eigenständigkeitserklärung für prüfungszugehörige Übungsblattabgaben
 SchoolAuthorshipStatementSheetExamDefinitionTip: Bitte in sowohl deutscher als auch englischer Sprache angeben.
 SchoolAuthorshipStatementSheetAllowOther: Abweichende Eigenständigkeitserklärungen für nicht-prüfungszugehörige Übungsblätter erlauben?
-SchoolAuthorshipStatementSheetExamAllowOther: Abweichende Eigenständigkeitserklärungen für prüfungszugehörige Übungsblätter erlauben?
+SchoolAuthorshipStatementSheetExamAllowOther: Abweichende Eigenständigkeitserklärungen für prüfungszugehörige Übungsblätter erlauben?
+
+DailyActDummy: Platzhalter ohne Funktion

messages/uniworx/categories/school/en-eu.msg

@@ -40,4 +40,6 @@ SchoolAuthorshipStatementSheetDefinitionTip: Please enter both german and englis
 SchoolAuthorshipStatementSheetExamDefinition: Statement of Authorship for exam-related exercise sheets
 SchoolAuthorshipStatementSheetExamDefinitionTip: Please enter both german and english statements.
 SchoolAuthorshipStatementSheetAllowOther: Allow adaptations for exam-unrelated exercise sheets?
-SchoolAuthorshipStatementSheetExamAllowOther: Allow adaptations for exam-related exercise sheets?
+SchoolAuthorshipStatementSheetExamAllowOther: Allow adaptations for exam-related exercise sheets?
+
+DailyActDummy: Placholder without function

messages/uniworx/utils/navigation/menu/de-de-formal.msg

@@ -97,7 +97,7 @@ MenuExamOfficeUsers: Benutzer:innen
 MenuLecturerInvite: Funktionäre hinzufügen
 MenuSchoolList: Bereiche
 MenuSchoolNew: Neuen Bereich anlegen
-MenuSchoolDay d@Text: #{d} Tagesansicht
+MenuSchoolDay ssh@SchoolId d@Text: #{unSchoolKey ssh} #{d} Tagesansicht
 MenuExternalExamGrades: Prüfungsleistungen
 MenuExternalExamUsers: Teilnehmer:innen
 MenuExternalExamEdit: Bearbeiten

messages/uniworx/utils/navigation/menu/en-eu.msg

@@ -97,7 +97,7 @@ MenuExamOfficeUsers: Users
 MenuLecturerInvite: Add functionaries
 MenuSchoolList: Departments
 MenuSchoolNew: Create new department
-MenuSchoolDay d@Text: #{d} Day
+MenuSchoolDay ssh d: #{unSchoolKey ssh} #{d} Day
 MenuExternalExamGrades: Exam results
 MenuExternalExamUsers: Participants
 MenuExternalExamEdit: Edit

routes

@@ -154,7 +154,7 @@
 !/term/#TermId/#SchoolId   TermSchoolCourseListR  GET          !free
 
 
-/school                    SchoolListR         GET
+/school                    SchoolListR         GET             !free
 !/school/new               SchoolNewR          GET POST
 /school/#SchoolId          SchoolR:
   /edit                      SchoolEditR       GET POST

src/Foundation/Navigation.hs

@@ -149,10 +149,10 @@ breadcrumb (SchoolR ssh SchoolEditR) =
     School{..} <- MaybeT $ get ssh
     isAdmin <- lift $ hasReadAccessTo SchoolListR
     return (CI.original schoolName, bool Nothing (Just SchoolListR) isAdmin)
-breadcrumb (SchoolR _ssh (SchoolDayR d)) = do
+breadcrumb (SchoolR ssh (SchoolDayR d)) = do
     dt <- formatTime SelFormatDate d
     mr <- getMessageRender
-    return (mr $ MsgMenuSchoolDay dt, Just SchoolListR)
+    return (mr $ MsgMenuSchoolDay ssh dt, Just SchoolListR)
 breadcrumb SchoolNewR       = i18nCrumb MsgMenuSchoolNew        $ Just SchoolListR
 
 breadcrumb (ExamOfficeR EOExamsR)  = i18nCrumb MsgMenuExamOfficeExams    Nothing
@@ -941,19 +941,37 @@ pageActions :: ( MonadHandler m
                , MonadUnliftIO m
                )
             => Route UniWorX -> m [Nav]
-pageActions NewsR = return
+pageActions NewsR = do
-  [ NavPageActionPrimary
+  now <- liftIO getCurrentTime
-    { navLink = NavLink
+  let nowaday = utctDay now
-      { navLabel       = MsgMenuOpenCourses
+  nd <- formatTime SelFormatDate now
-      , navRoute       = (CourseListR, [("courses-openregistration", toPathPiece True)])
+  schools <- useRunDB $ selectList [] [Asc SchoolShorthand]
-      , navAccess'     = NavAccessTrue
+  return $
-      , navType        = NavTypeLink { navModal = False }
+    ( NavPageActionPrimary
-      , navQuick'      = mempty
+      { navLink = NavLink
-      , navForceActive = False
+        { navLabel       = MsgMenuOpenCourses
+        , navRoute       = (CourseListR, [("courses-openregistration", toPathPiece True)])
+        , navAccess'     = NavAccessTrue
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
       }
-    , navChildren = []
+    ) :
-    }
+    [ NavPageActionPrimary
-  ]
+      { navLink = NavLink
+        { navLabel       = MsgMenuSchoolDay ssh nd
+        , navRoute       = SchoolR ssh $ SchoolDayR nowaday
+        , navAccess'     = NavAccessTrue
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
+      }
+    | sch <- schools, let ssh = sch ^. _entityKey
+    ]
 pageActions (CourseR tid ssh csh CShowR) = do
   materialListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh MaterialListR
   tutorialListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CTutorialListR

src/Handler/School/DayTasks.hs

@@ -11,26 +11,139 @@ module Handler.School.DayTasks
 
 import Import
 
--- import Handler.Utils
+import Handler.Utils
 
--- import qualified Data.Set as Set
+import qualified Data.Set as Set
--- import qualified Data.Map as Map
+import qualified Data.Map as Map
--- import qualified Data.Aeson  as Aeson
+import qualified Data.Aeson  as Aeson
 -- import qualified Data.Text as Text
 
 -- import Database.Persist.Sql (updateWhereCount)
--- import           Database.Esqueleto.Experimental ((:&)(..))
+import           Database.Esqueleto.Experimental ((:&)(..))
--- -- import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy
+import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy
--- import qualified Database.Esqueleto.Experimental as E
+import qualified Database.Esqueleto.Experimental as E
--- import qualified Database.Esqueleto.Utils as E
+import qualified Database.Esqueleto.Utils as E
--- import Database.Esqueleto.Utils.TH
+import Database.Esqueleto.Utils.TH
+import Database.Esqueleto.PostgreSQL.JSON as E
 
 
+data DailyTableAction = DailyActDummy -- just a dummy, since we don't now yet which actions we will be needing
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+
+instance Universe DailyTableAction
+instance Finite DailyTableAction
+nullaryPathPiece ''DailyTableAction $ camelToPathPiece' 2
+embedRenderMessage ''UniWorX ''DailyTableAction id
+
+data DailyTableActionData  = DailyActDummyData
+  deriving (Eq, Ord, Read, Show, Generic)
+
+-- | partial JSON object to be used for filtering with "@>"
+occurrenceDayValue :: Day -> Value
+occurrenceDayValue d = Aeson.object
+  [ "exceptions" Aeson..=
+    [ Aeson.object
+      [ "exception" Aeson..= ("occur"::Text)
+      , "day"       Aeson..= d
+  ] ] ]
+-- TODO: ensure that an appropriate GIN index for the jsonb column is set
+
+
+
+type DailyTableExpr =
+  (               E.SqlExpr (Entity Course)
+    `E.InnerJoin` E.SqlExpr (Entity Tutorial)
+  )
+
+queryCourse :: DailyTableExpr -> E.SqlExpr (Entity Course)
+queryCourse = $(sqlIJproj 2 1)
+
+
+queryTutorial :: DailyTableExpr -> E.SqlExpr (Entity Tutorial)
+queryTutorial = $(sqlIJproj 2 2)
+
+
+type DailyTableData = DBRow (Entity Course, Entity Tutorial)
+
+resultCourse :: Lens' DailyTableData (Entity Course)
+resultCourse = _dbrOutput . _1
+
+resultTutorial :: Lens' DailyTableData (Entity Tutorial)
+resultTutorial = _dbrOutput . _2
+
+
+mkDailyTable :: SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget)
+mkDailyTable ssh nd = do
+  let
+    dbtSQLQuery :: DailyTableExpr -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity Tutorial))
+    dbtSQLQuery  (course `E.InnerJoin` tut) = do
+      EL.on $ course E.^. CourseId E.==. tut E.^. TutorialCourse
+      E.where_ $ course E.^. CourseSchool E.==. E.val ssh
+        E.&&.  ((tut    E.^. TutorialTime) @>. (E.jsonbVal $ occurrenceDayValue nd)
+               )
+      return (course, tut)
+    dbtRowKey = queryTutorial >>> (E.^. TutorialId)
+    dbtProj = dbtProjId
+    dbtColonnade = mconcat
+      [ -- dbSelect (applying _2) id (return . view (resultTutorial . _entityKey))
+        sortable (Just "course")    (i18nCell MsgFilterCourse)     $ \(view $ resultCourse   . _entityVal . _courseName   . _CI -> t) -> textCell t
+      , sortable (Just "tutorial")  (i18nCell MsgCourseTutorial)   $ \(view $ resultTutorial . _entityVal . _tutorialName . _CI -> t) -> textCell t
+      ]
+    dbtSorting = Map.fromList
+      [ ("course"      , SortColumn $ queryCourse   >>> (E.^. CourseName))
+      , ("tutorial"    , SortColumn $ queryTutorial >>> (E.^. TutorialName))
+      ]
+    dbtFilter = Map.fromList
+      [ ("course"   , FilterColumn . E.mkContainsFilter $ queryCourse   >>> (E.^. CourseName))
+      , ("tutorial" , FilterColumn . E.mkContainsFilter $ queryTutorial >>> (E.^. TutorialName))
+      ]
+    dbtFilterUI mPrev = mconcat
+      [ prismAForm (singletonFilter "course"   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgFilterCourse)
+      , prismAForm (singletonFilter "tutorial" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgCourseTutorial)
+
+      ]
+    dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
+    dbtIdent :: Text
+    dbtIdent = "daily"
+    dbtCsvEncode = noCsvEncode
+    dbtCsvDecode = Nothing
+    dbtExtraReps = []
+    dbtParams = DBParamsForm
+      { dbParamsFormMethod = POST
+      , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
+      , dbParamsFormAttrs  = []
+      , dbParamsFormSubmit = FormNoSubmit
+      , dbParamsFormAdditional = \_csrf -> return (FormMissing, mempty)
+      -- , dbParamsFormSubmit = FormSubmit
+      -- , dbParamsFormAdditional
+      --     = let acts :: Map MCTableAction (AForm Handler MCTableActionData)
+      --           acts = mconcat
+      --             [ singletonMap MCActDummy $ pure MCActDummyData
+      --             ]
+      --        in renderAForm FormStandard
+      --          $  (, mempty) . First . Just
+      --         <$> multiActionA acts (fslI MsgTableAction) Nothing
+      , dbParamsFormEvaluate = liftHandler . runFormPost
+      , dbParamsFormResult   = id
+      , dbParamsFormIdent    = def
+      }
+    postprocess :: FormResult (First DailyTableActionData, DBFormResult TutorialId Bool DailyTableData)
+                -> FormResult (      DailyTableActionData,          Set TutorialId)
+    postprocess inp = do
+        (First (Just act), jobMap) <- inp
+        let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
+        return (act, jobSet)
+    psValidator = def & defaultSorting [SortAscBy "course", SortAscBy "tutorial"]
+  over _1 postprocess <$> dbTable psValidator DBTable{..}
 
 
 getSchoolDayR,  postSchoolDayR :: SchoolId -> Day -> Handler Html
 getSchoolDayR = postSchoolDayR
-postSchoolDayR _ssh _day = do
+postSchoolDayR ssh nd = do
-  siteLayout "TODO" $ do
+  dday <- formatTime SelFormatDate nd
-    setTitle "Day Tasks"
+  tableDaily <- runDB $ mkDailyTable ssh nd
-    [whamlet|TODO|]
+  siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do
+    setTitleI (MsgMenuSchoolDay ssh dday)
+    [whamlet|TODO Overview School #{ciOriginal (unSchoolKey ssh)}
+      ^{tableDaily}
+    |]

test/Database/Fill.hs

@@ -1087,6 +1087,11 @@ fillDb = do
                     , exceptStart = TimeOfDay  9  0  0
                     , exceptEnd   = TimeOfDay 16  0  0
                     }
+                , ExceptOccur
+                    { exceptDay   = nowaday
+                    , exceptStart = TimeOfDay  9  10  0
+                    , exceptEnd   = TimeOfDay 16  10  0
+                    }
                 ]
             }
           , tutorialRegGroup        = Just "Schulung"
@@ -1128,6 +1133,11 @@ fillDb = do
                     , exceptStart = TimeOfDay 10  12  0
                     , exceptEnd   = TimeOfDay 12  13  0
                     }
+                , ExceptOccur
+                    { exceptDay   = nowaday
+                    , exceptStart = TimeOfDay 17  10  0
+                    , exceptEnd   = TimeOfDay 18  10  0
+                    }
                 ]
             }
           , tutorialRegGroup        = Just "schulung"