fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix(dbtable): improve sorting for haskell+sql

Browse Source
This commit is contained in:
Gregor Kleen 2020-03-16 11:42:02 +01:00
parent 731231d5ea
commit fd8255de8c
4 changed files with 12 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
frontend/src/app.sass
View File

@ -1182,7 +1182,7 @@ a.breadcrumbs__home
font-size: 14px font-size: 14px
font-family: monospace font-family: monospace
.func-field__wrapper, .allocation-missing-prios .func-field__wrapper, .allocation-missing-prios, .allocation-users__accept
max-height: 75vh max-height: 75vh
overflow: auto overflow: auto

1
src/Handler/Allocation/Accept.hs
View File

@ -54,7 +54,6 @@ allocationAcceptForm aId = runMaybeT $ do
Allocation{..} <- MaybeT $ get aId Allocation{..} <- MaybeT $ get aId
SessionDataAllocationResults allocMap <- MaybeT $ lookupSessionJson SessionAllocationResults SessionDataAllocationResults allocMap <- MaybeT $ lookupSessionJson SessionAllocationResults
allocRes@(allocTime, allocFp, allocMatching, _ :|> MatchingLogRun{..}) <- hoistMaybe $ allocMap !? (allocationTerm, allocationSchool, allocationShorthand) allocRes@(allocTime, allocFp, allocMatching, _ :|> MatchingLogRun{..}) <- hoistMaybe $ allocMap !? (allocationTerm, allocationSchool, allocationShorthand)
$logInfoS "allocationAcceptForm" $ tshow allocRes
allocationUsers <- fmap (map $ bimap E.unValue E.unValue) . lift . E.select . E.from $ \allocationUser -> do allocationUsers <- fmap (map $ bimap E.unValue E.unValue) . lift . E.select . E.from $ \allocationUser -> do
E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val aId E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val aId

19
src/Handler/Utils/Table/Pagination.hs
View File

@ -465,8 +465,8 @@ defaultSorting :: [SortingSetting] -> PSValidator m x -> PSValidator m x
defaultSorting psSorting (runPSValidator -> f) = PSValidator $ \dbTable' -> injectDefault <*> f dbTable' defaultSorting psSorting (runPSValidator -> f) = PSValidator $ \dbTable' -> injectDefault <*> f dbTable'
where where
injectDefault x = case x >>= piSorting of injectDefault x = case x >>= piSorting of
Just _ -> id Just prev -> _2 . _psSorting <>~ filter (\ss -> none (((==) `on` sortKey) ss) prev) psSorting
Nothing -> set (_2._psSorting) psSorting Nothing -> set (_2 . _psSorting) psSorting
defaultPagesize :: PagesizeLimit -> PSValidator m x -> PSValidator m x defaultPagesize :: PagesizeLimit -> PSValidator m x -> PSValidator m x
defaultPagesize psLimit (runPSValidator -> f) = PSValidator $ \dbTable' -> injectDefault <*> f dbTable' defaultPagesize psLimit (runPSValidator -> f) = PSValidator $ \dbTable' -> injectDefault <*> f dbTable'
@ -996,15 +996,15 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
psFilter' = imap (\key args -> (, args) $ Map.findWithDefault (error $ "Invalid filter key: " <> show key) key dbtFilter) psFilter psFilter' = imap (\key args -> (, args) $ Map.findWithDefault (error $ "Invalid filter key: " <> show key) key dbtFilter) psFilter
sortSql :: Maybe (_ -> [E.SqlExpr E.OrderBy]) primarySortSql = flip has psSorting' $ _head . _1 . to sqlSortDirection . _Just
sortSql = do
sqlSorting <- mapM (\(c, d) -> (, d) <$> sqlSortDirection c) psSorting' sortSql :: _ -> [E.SqlExpr E.OrderBy]
return $ \t -> concatMap (\(f, d) -> f d t) sqlSorting sortSql t = concatMap (\(f, d) -> f d t) $ mapMaybe (\(c, d) -> (, d) <$> sqlSortDirection c) psSorting'
filterSql :: Map FilterKey (Maybe (_ -> E.SqlExpr (E.Value Bool))) filterSql :: Map FilterKey (Maybe (_ -> E.SqlExpr (E.Value Bool)))
filterSql = map (\(fc, args) -> ($ args) <$> filterColumn fc) $ psFilter' filterSql = map (\(fc, args) -> ($ args) <$> filterColumn fc) $ psFilter'
selectPagesize = is _Just sortSql selectPagesize = primarySortSql
&& all (is _Just) filterSql && all (is _Just) filterSql
psLimit' = bool PagesizeAll psLimit selectPagesize psLimit' = bool PagesizeAll psLimit selectPagesize
@ -1012,8 +1012,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
rows' <- E.select . E.from $ \t -> do rows' <- E.select . E.from $ \t -> do
res <- dbtSQLQuery t res <- dbtSQLQuery t
whenIsJust sortSql $ \mkSorting -> E.orderBy $ sortSql t
E.orderBy $ mkSorting t
case csvMode of case csvMode of
FormSuccess DBCsvExport{} -> return () FormSuccess DBCsvExport{} -> return ()
FormSuccess DBCsvImport{} -> return () FormSuccess DBCsvImport{} -> return ()
@ -1048,6 +1047,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
sortProjected sortProjected
| is _Just previousKeys | is _Just previousKeys
= id = id
| primarySortSql
= id
| otherwise | otherwise
= sortBy $ concatMap (\(c, d) (_, r) (_, r') -> adjustOrder d $ sortDirectionProjected c r r') psSorting' = sortBy $ concatMap (\(c, d) (_, r) (_, r') -> adjustOrder d $ sortDirectionProjected c r r') psSorting'
where where

2
templates/allocation/users.hamlet
View File

@ -1,6 +1,6 @@
$newline never $newline never
$maybe acceptWgt <- acceptView $maybe acceptWgt <- acceptView
<section> <section .allocation-users__accept>
^{acceptWgt} ^{acceptWgt}
<section> <section>
^{usersTable} ^{usersTable}