chore(TH): add sqlMIXproj to improve dbTable usage, also add card-nos to DayTask Table
This commit is contained in:
parent
8506c4d7e0
commit
4fc6f54b32
@ -9,7 +9,7 @@ module Database.Esqueleto.Utils.TH
|
||||
, sqlInTuple, sqlInTuples
|
||||
, _unValue
|
||||
, unValueN, unValueNIs
|
||||
, sqlIJproj, sqlLOJproj, sqlFOJproj
|
||||
, sqlIJproj, sqlLOJproj, sqlFOJproj, sqlMIXproj, sqlMIXproj'
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
@ -99,7 +99,7 @@ unValueNIs arity uvIdx = do
|
||||
-- | Generic projections for InnerJoin-tuples
|
||||
-- gives I-th element of N-tuple of left-associative InnerJoin-pairs, i.e.
|
||||
--
|
||||
-- > $(projN n m) :: (t1 `E.InnerJoin` .. `E.InnerJoin` tn) -> tm@ (for m<=n)
|
||||
-- > $(sqlIJproj n m) :: (t1 `E.InnerJoin` .. `E.InnerJoin` tn) -> tm@ (for m<=n)
|
||||
sqlIJproj :: Int -> Int -> ExpQ
|
||||
sqlIJproj = leftAssociativePairProjection 'E.InnerJoin
|
||||
|
||||
@ -108,3 +108,27 @@ sqlLOJproj = leftAssociativePairProjection 'E.LeftOuterJoin
|
||||
|
||||
sqlFOJproj :: Int -> Int -> ExpQ
|
||||
sqlFOJproj = leftAssociativePairProjection 'E.FullOuterJoin
|
||||
|
||||
-- | Generic projections for Join-tuple
|
||||
-- gives i-th element of n-tuple of left-associative join pairs, i.e.
|
||||
--
|
||||
-- > $(sqlMIXproj "IR" 3) :: ((t1 `E.InnerJoin` t2) `E.RightOuterJoin` t3) -> t3
|
||||
sqlMIXproj :: String -> Int -> ExpQ
|
||||
sqlMIXproj = leftAssociativeProjection . map decodeJoin
|
||||
where
|
||||
decodeJoin 'I' = 'E.InnerJoin
|
||||
decodeJoin 'L' = 'E.LeftOuterJoin
|
||||
decodeJoin 'R' = 'E.RightOuterJoin
|
||||
decodeJoin 'F' = 'E.FullOuterJoin
|
||||
decodeJoin 'O' = 'E.FullOuterJoin
|
||||
decodeJoin 'X' = 'E.CrossJoin
|
||||
decodeJoin 'C' = 'E.CrossJoin
|
||||
decodeJoin c = error $ "Database.Esqueleto.Utils.TH.sqlMIXproj: received unknown SQL join kind \"" ++ c:"\"" -- always raised at compile time, so this is ok
|
||||
|
||||
-- Alternative using `refiy`, but impractical due to TH staging restrictions
|
||||
-- and currently confuses type and expression constructors somehow
|
||||
sqlMIXproj' :: Name -> Int -> ExpQ
|
||||
sqlMIXproj' t i = do
|
||||
ns <- extractConstructorNames t
|
||||
-- ns' <- maybeMapM (lookupValueName . nameBase) ns -- failed attempt change type-constructor names to identical expression-constructors
|
||||
leftAssociativeProjection ns i
|
||||
|
||||
@ -299,19 +299,22 @@ instance CsvColumnsExplained LmsTableCsv where
|
||||
type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser)
|
||||
`E.InnerJoin` E.SqlExpr (Entity User)
|
||||
`E.InnerJoin` E.SqlExpr (Entity LmsUser)
|
||||
) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock))
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock))
|
||||
)
|
||||
-- due to GHC staging restrictions, we use the preprocessor instead
|
||||
#define LMS_TABLE_JOIN "IIL"
|
||||
|
||||
queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser)
|
||||
queryQualUser = $(sqlIJproj 3 1) . $(sqlLOJproj 2 1)
|
||||
queryQualUser = $(sqlMIXproj LMS_TABLE_JOIN 1)
|
||||
|
||||
queryUser :: LmsTableExpr -> E.SqlExpr (Entity User)
|
||||
queryUser = $(sqlIJproj 3 2) . $(sqlLOJproj 2 1)
|
||||
queryUser = $(sqlMIXproj LMS_TABLE_JOIN 2)
|
||||
|
||||
queryLmsUser :: LmsTableExpr -> E.SqlExpr (Entity LmsUser)
|
||||
queryLmsUser = $(sqlIJproj 3 3) . $(sqlLOJproj 2 1)
|
||||
queryLmsUser = $(sqlMIXproj LMS_TABLE_JOIN 3)
|
||||
|
||||
queryQualBlock :: LmsTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock))
|
||||
queryQualBlock = $(sqlLOJproj 2 2)
|
||||
queryQualBlock = $(sqlMIXproj LMS_TABLE_JOIN 4)
|
||||
|
||||
|
||||
type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), E.Value (Maybe CompanyId), E.Value Bool)
|
||||
|
||||
@ -28,8 +28,10 @@ import qualified Database.Esqueleto.Experimental as E
|
||||
import qualified Database.Esqueleto.PostgreSQL as E
|
||||
import qualified Database.Esqueleto.Legacy as EL (on, from) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import Database.Esqueleto.PostgreSQL.JSON ((@>.))
|
||||
import qualified Database.Esqueleto.PostgreSQL.JSON as E hiding ((?.))
|
||||
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
|
||||
@ -95,33 +97,59 @@ getDayTutorials ssh dlimit@(dstart, dend )
|
||||
| otherwise
|
||||
= Nothing
|
||||
|
||||
|
||||
type DailyTableExpr =
|
||||
( E.SqlExpr (Entity Course)
|
||||
`E.InnerJoin` E.SqlExpr (Entity Tutorial)
|
||||
`E.InnerJoin` E.SqlExpr (Entity TutorialParticipant)
|
||||
`E.InnerJoin` E.SqlExpr (Entity User)
|
||||
( E.SqlExpr (Entity Course)
|
||||
`E.InnerJoin` E.SqlExpr (Entity Tutorial)
|
||||
`E.InnerJoin` E.SqlExpr (Entity TutorialParticipant)
|
||||
`E.InnerJoin` E.SqlExpr (Entity User)
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserAvs))
|
||||
)
|
||||
-- due to GHC staging restrictions, we use the preprocessor instead
|
||||
#define DAILY_TABLE_JOIN "IIIL"
|
||||
|
||||
-- force declarations before this point
|
||||
$(return [])
|
||||
|
||||
|
||||
type DailyTableOutput = E.SqlQuery
|
||||
( E.SqlExpr (Entity Course)
|
||||
, E.SqlExpr (Entity Tutorial)
|
||||
, E.SqlExpr (Entity TutorialParticipant)
|
||||
, E.SqlExpr (Entity User)
|
||||
, E.SqlExpr (Maybe (Entity UserAvs))
|
||||
, E.SqlExpr (E.Value (Maybe CompanyId))
|
||||
, E.SqlExpr (E.Value (Maybe [QualificationId]))
|
||||
)
|
||||
type DailyTableOutput = E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity Tutorial), E.SqlExpr (Entity TutorialParticipant), E.SqlExpr (Entity User), E.SqlExpr (E.Value (Maybe CompanyId)), E.SqlExpr (E.Value (Maybe [QualificationId])))
|
||||
type DailyTableData = DBRow
|
||||
( Entity Course
|
||||
, Entity Tutorial
|
||||
, Entity TutorialParticipant
|
||||
, Entity User
|
||||
, Maybe (Entity UserAvs)
|
||||
, E.Value (Maybe CompanyId)
|
||||
, E.Value (Maybe [QualificationId])
|
||||
)
|
||||
|
||||
-- force declarations before this point
|
||||
$(return [])
|
||||
|
||||
|
||||
queryCourse :: DailyTableExpr -> E.SqlExpr (Entity Course)
|
||||
queryCourse = $(sqlIJproj 4 1)
|
||||
queryCourse = $(sqlMIXproj DAILY_TABLE_JOIN 1)
|
||||
|
||||
queryTutorial :: DailyTableExpr -> E.SqlExpr (Entity Tutorial)
|
||||
queryTutorial = $(sqlIJproj 4 2)
|
||||
queryTutorial = $(sqlMIXproj DAILY_TABLE_JOIN 2)
|
||||
|
||||
queryParticipant :: DailyTableExpr -> E.SqlExpr (Entity TutorialParticipant)
|
||||
queryParticipant = $(sqlIJproj 4 3)
|
||||
-- queryParticipant = $(sqlMIXproj' ''DailyTableExpr 3) -- TODO reify seems problematic for now
|
||||
queryParticipant = $(sqlMIXproj DAILY_TABLE_JOIN 3)
|
||||
|
||||
queryUser :: DailyTableExpr -> E.SqlExpr (Entity User)
|
||||
queryUser = $(sqlIJproj 4 4)
|
||||
queryUser = $(sqlMIXproj DAILY_TABLE_JOIN 4)
|
||||
|
||||
queryUserAvs :: DailyTableExpr -> E.SqlExpr (Maybe (Entity UserAvs))
|
||||
queryUserAvs = $(sqlMIXproj DAILY_TABLE_JOIN 5)
|
||||
|
||||
resultCourse :: Lens' DailyTableData (Entity Course)
|
||||
resultCourse = _dbrOutput . _1
|
||||
@ -132,17 +160,17 @@ resultTutorial = _dbrOutput . _2
|
||||
resultParticipant :: Lens' DailyTableData (Entity TutorialParticipant)
|
||||
resultParticipant = _dbrOutput . _3
|
||||
|
||||
-- resultCompanyId :: Traversal' DailyTableData CompanyId
|
||||
-- resultCompanyId = _dbrOutput . _3 . _entityVal . _tutorialParticipantCompany . _Just
|
||||
|
||||
resultUser :: Lens' DailyTableData (Entity User)
|
||||
resultUser = _dbrOutput . _4
|
||||
|
||||
resultUserAvs :: Traversal' DailyTableData UserAvs
|
||||
resultUserAvs = _dbrOutput . _5 . _Just . _entityVal
|
||||
|
||||
resultCompanyId :: Traversal' DailyTableData CompanyId
|
||||
resultCompanyId = _dbrOutput . _5 . _unValue . _Just
|
||||
resultCompanyId = _dbrOutput . _6 . _unValue . _Just
|
||||
|
||||
resultCourseQualis :: Traversal' DailyTableData [QualificationId]
|
||||
resultCourseQualis = _dbrOutput . _6 . _unValue . _Just
|
||||
resultCourseQualis = _dbrOutput . _7 . _unValue . _Just
|
||||
|
||||
|
||||
instance HasEntity DailyTableData User where
|
||||
@ -151,22 +179,26 @@ instance HasEntity DailyTableData User where
|
||||
instance HasUser DailyTableData where
|
||||
hasUser = resultUser . _entityVal
|
||||
|
||||
-- see colRatedField' for an example of formCell usage
|
||||
|
||||
|
||||
mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget)
|
||||
mkDailyTable isAdmin ssh nd = do
|
||||
tuts <- getDayTutorials ssh (nd,nd)
|
||||
let
|
||||
dbtSQLQuery :: DailyTableExpr -> DailyTableOutput
|
||||
dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr) = do
|
||||
dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr `E.LeftOuterJoin` avs) = do
|
||||
EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId
|
||||
EL.on $ tut E.^. TutorialId E.==. tpu E.^. TutorialParticipantTutorial
|
||||
EL.on $ usr E.^. UserId E.==. tpu E.^. TutorialParticipantUser
|
||||
EL.on $ usr E.^. UserId E.=?. avs E.?. UserAvsUser
|
||||
E.where_ $ tut E.^. TutorialId `E.in_` E.valList tuts
|
||||
let associatedQualifications = E.subSelectMaybe . EL.from $ \cq -> do
|
||||
E.where_ $ cq E.^. CourseQualificationCourse E.==. crs E.^. CourseId
|
||||
let cqQual = cq E.^. CourseQualificationQualification
|
||||
cqOrder = [E.asc $ cq E.^. CourseQualificationSortOrder, E.asc cqQual]
|
||||
return $ E.arrayAggWith E.AggModeAll cqQual cqOrder
|
||||
return (crs, tut, tpu, usr, selectCompanyUserPrime usr, associatedQualifications)
|
||||
return (crs, tut, tpu, usr, avs, selectCompanyUserPrime usr, associatedQualifications)
|
||||
dbtRowKey = queryTutorial >>> (E.^. TutorialId)
|
||||
dbtProj = dbtProjId
|
||||
dbtColonnade = mconcat
|
||||
@ -182,6 +214,7 @@ mkDailyTable isAdmin ssh nd = do
|
||||
, sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid
|
||||
, colUserNameModalHdr MsgCourseParticipant ForProfileDataR
|
||||
, colUserMatriclenr isAdmin
|
||||
, sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn
|
||||
]
|
||||
dbtSorting = Map.fromList
|
||||
[ sortUserNameLink queryUser
|
||||
@ -190,6 +223,7 @@ mkDailyTable isAdmin ssh nd = do
|
||||
, ("tutorial" , SortColumn $ queryTutorial >>> (E.^. TutorialName))
|
||||
, ("user-company" , SortColumn $ queryUser >>> selectCompanyUserPrime)
|
||||
, ("booking-company", SortColumn $ queryParticipant >>> (E.^. TutorialParticipantCompany))
|
||||
, ("card-no" , SortColumn $ queryUserAvs >>> (E.?. UserAvsLastCardNo))
|
||||
]
|
||||
dbtFilter = Map.fromList
|
||||
[ fltrUserNameEmail queryUser
|
||||
|
||||
@ -55,6 +55,98 @@ leftAssociativePairProjection constructor n i = do
|
||||
| w==i = conP constructor [wildP, varP x]
|
||||
| otherwise = conP constructor [pat x (pred w), wildP]
|
||||
|
||||
-- | Generic projections N-tuples that are actually left-associative pairs with differing constructors
|
||||
-- i.e. @$(leftAssociativePairProjection [c1,c2,..,cn] m :: (..(t1 `c1` t2) `c2` .. `cn` t(n+1) -> tm@ (for m<=n+1)
|
||||
leftAssociativeProjection :: [Name] -> Int -> ExpQ
|
||||
leftAssociativeProjection constructors@(length -> n) (pred -> i)
|
||||
| n < i = error $ "leftAssciativeProjection not given enough constructors: " <> show constructors
|
||||
| otherwise = do
|
||||
x <- newName "x"
|
||||
lamE [pat x n] (varE x)
|
||||
where
|
||||
pat x 0 = varP x
|
||||
pat x w@(pred -> v)
|
||||
| w==i = conP (constructors !! v) [wildP, varP x]
|
||||
| otherwise = conP (constructors !! v) [pat x v, wildP]
|
||||
|
||||
-- Extract constructor names from a type definition of left-associative pair-constructors
|
||||
-- PROBLEM: returns the wrong names: E.g. for `data LeftOuterJoinTC a b = a `LeftOuterJoinEC` b we get `LeftOuterJoinTC`, but we need `LeftOuterJoinEC`
|
||||
extractConstructorNames :: Name -> Q [Name]
|
||||
extractConstructorNames td = do
|
||||
TyConI (TySynD _ [] ty) <- reify td
|
||||
return (go ty)
|
||||
where
|
||||
go :: Type -> [Name]
|
||||
go (AppT (AppT (ConT name) rest) _) = name : go rest
|
||||
go _ = []
|
||||
|
||||
{-
|
||||
Example:
|
||||
|
||||
Suppose
|
||||
type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser)
|
||||
`E.InnerJoin` E.SqlExpr (Entity User)
|
||||
`E.InnerJoin` E.SqlExpr (Entity LmsUser)
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock))
|
||||
)
|
||||
then
|
||||
info <- reify ''LmsTableExpr
|
||||
with
|
||||
info = TyConI (TySynD Handler.Utils.LMS.LmsTableExpr []
|
||||
(AppT
|
||||
(AppT
|
||||
(ConT Database.Esqueleto.Internal.Internal.LeftOuterJoin)
|
||||
(AppT
|
||||
(AppT
|
||||
(ConT Database.Esqueleto.Internal.Internal.InnerJoin)
|
||||
(AppT
|
||||
(AppT
|
||||
(ConT Database.Esqueleto.Internal.Internal.InnerJoin)
|
||||
(AppT
|
||||
(ConT Database.Esqueleto.Internal.Internal.SqlExpr)
|
||||
(AppT
|
||||
(ConT Database.Persist.Class.PersistEntity.Entity)
|
||||
(ConT Model.QualificationUser)
|
||||
) ) )
|
||||
(AppT (ConT Database.Esqueleto.Internal.Internal.SqlExpr)
|
||||
(AppT
|
||||
(ConT Database.Persist.Class.PersistEntity.Entity)
|
||||
(ConT Model.User)
|
||||
) ) ) ) )
|
||||
(AppT
|
||||
(ConT Database.Esqueleto.Internal.Internal.SqlExpr)
|
||||
(AppT
|
||||
(ConT Database.Persist.Class.PersistEntity.Entity)
|
||||
(ConT Model.LmsUser)
|
||||
) ) ) )
|
||||
(AppT
|
||||
(ConT Database.Esqueleto.Internal.Internal.SqlExpr)
|
||||
(AppT
|
||||
(ConT GHC.Maybe.Maybe)
|
||||
(AppT
|
||||
(ConT Database.Persist.Class.PersistEntity.Entity)
|
||||
(ConT Model.QualificationUserBlock)
|
||||
) ) ) ) )
|
||||
|
||||
At this point we have the Type-Constructors, but we actually need the Data-Constructors.
|
||||
We might possibly use something like the following:
|
||||
|
||||
getDataConstructors :: Name -> Q [Name]
|
||||
getDataConstructors conName = do
|
||||
info <- reify conName
|
||||
case info of
|
||||
TyConI (DataD _ _ _ _ cons _) -> return $ concatMap getConNames cons
|
||||
TyConI (NewtypeD _ _ _ _ con _) -> return $ getConNames con
|
||||
_ -> return []
|
||||
|
||||
getConNames :: Con -> [Name]
|
||||
getConNames (NormalC name _) = [name]
|
||||
getConNames (RecC name _) = [name]
|
||||
getConNames (InfixC _ name _) = [name]
|
||||
getConNames (ForallC _ _ con) = getConNames con
|
||||
getConNames _ = []
|
||||
-}
|
||||
|
||||
|
||||
---------------
|
||||
-- Functions --
|
||||
|
||||
@ -744,10 +744,10 @@ fillDb = do
|
||||
for_ [jost] $ \uid ->
|
||||
void . insert' $ UserSchool uid avn False
|
||||
void . insert' $ UserAvs (AvsPersonId 12345678) jost 87654321 (n_day' $ -12) (Just "Some Message here") Nothing Nothing Nothing
|
||||
void . insert' $ UserAvs (AvsPersonId 2) svaupel 2 (n_day' $ -22) Nothing Nothing Nothing Nothing
|
||||
void . insert' $ UserAvs (AvsPersonId 2) svaupel 2 (n_day' $ -22) Nothing Nothing Nothing (readAvsFullCardNo "12345.6")
|
||||
void . insert' $ UserAvs (AvsPersonId 3) gkleen 3 (n_day' $ -32) Nothing Nothing Nothing Nothing
|
||||
void . insert' $ UserAvs (AvsPersonId 4) sbarth 4 now Nothing Nothing Nothing Nothing
|
||||
void . insert' $ UserAvs (AvsPersonId 5) fhamann 5 now (Just "another message from avs synch") Nothing Nothing Nothing
|
||||
void . insert' $ UserAvs (AvsPersonId 5) fhamann 5 now (Just "another message from avs synch") Nothing Nothing (readAvsFullCardNo "77777.7")
|
||||
void . insert' $ UserAvs (AvsPersonId 77) tinaTester 77 now Nothing Nothing Nothing Nothing
|
||||
|
||||
let f_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user