chore(daily): improve stub #90 change DB to JSONB (WIP)
This commit is contained in:
parent
0264c87510
commit
5a03d1cabe
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
2
routes
2
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
|
||||
|
||||
@ -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
|
||||
[ NavPageActionPrimary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = MsgMenuOpenCourses
|
||||
, navRoute = (CourseListR, [("courses-openregistration", toPathPiece True)])
|
||||
, navAccess' = NavAccessTrue
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
pageActions NewsR = do
|
||||
now <- liftIO getCurrentTime
|
||||
let nowaday = utctDay now
|
||||
nd <- formatTime SelFormatDate now
|
||||
schools <- useRunDB $ selectList [] [Asc SchoolShorthand]
|
||||
return $
|
||||
( NavPageActionPrimary
|
||||
{ navLink = NavLink
|
||||
{ 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
|
||||
|
||||
@ -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.Map as Map
|
||||
-- import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Aeson as Aeson
|
||||
-- import qualified Data.Text as Text
|
||||
|
||||
-- import Database.Persist.Sql (updateWhereCount)
|
||||
-- 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.Experimental as E
|
||||
-- import qualified Database.Esqueleto.Utils as E
|
||||
-- import Database.Esqueleto.Utils.TH
|
||||
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.Experimental as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
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
|
||||
siteLayout "TODO" $ do
|
||||
setTitle "Day Tasks"
|
||||
[whamlet|TODO|]
|
||||
postSchoolDayR ssh nd = do
|
||||
dday <- formatTime SelFormatDate nd
|
||||
tableDaily <- runDB $ mkDailyTable ssh nd
|
||||
siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do
|
||||
setTitleI (MsgMenuSchoolDay ssh dday)
|
||||
[whamlet|TODO Overview School #{ciOriginal (unSchoolKey ssh)}
|
||||
^{tableDaily}
|
||||
|]
|
||||
|
||||
@ -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"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user