fix(dbtable): improve sorting for haskell+sql

frontend/src/app.sass

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

src/Handler/Allocation/Accept.hs

@@ -54,7 +54,6 @@ allocationAcceptForm aId = runMaybeT $ do
   Allocation{..} <- MaybeT $ get aId
   SessionDataAllocationResults allocMap <- MaybeT $ lookupSessionJson SessionAllocationResults
   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
     E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val aId

src/Handler/Utils/Table/Pagination.hs

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

templates/allocation/users.hamlet

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