chore(TH): add sqlMIXproj to improve dbTable usage, also add card-nos to DayTask Table

src/Database/Esqueleto/Utils/TH.hs

@@ -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

src/Handler/LMS.hs

@@ -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)

src/Handler/School/DayTasks.hs

@@ -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.SqlExpr (Entity Course)
-    `E.InnerJoin` E.SqlExpr (Entity Tutorial)
+    `E.InnerJoin`       E.SqlExpr (Entity Tutorial)
-    `E.InnerJoin` E.SqlExpr (Entity TutorialParticipant)
+    `E.InnerJoin`       E.SqlExpr (Entity TutorialParticipant)
-    `E.InnerJoin` E.SqlExpr (Entity User)
+    `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

src/Utils/TH.hs

@@ -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 --

test/Database/Fill.hs

@@ -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.|]