Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

messages/de.msg

@@ -1,6 +1,7 @@
 SummerTerm year@Integer: Sommersemester #{tshow year}
 WinterTerm year@Integer: Wintersemester #{tshow year}/#{tshow $ succ year}
 PSLimitNonPositive: “pagesize” muss größer als null sein
+Page n@Int64 num@Int64: Seite #{tshow n} von #{tshow num}
 TermEdited tid@TermIdentifier: Semester #{termToText tid} erfolgreich editiert.
 TermNewTitle: Semester editiere/anlegen.
 InvalidInput: Eingaben bitte korrigieren.

src/Handler/Term.hs

@@ -30,7 +30,7 @@ getTermShowR = do
 --
   let
     termData = E.from $ \term -> do
-      E.orderBy [E.desc $ term E.^. TermStart ]
+      -- E.orderBy [E.desc $ term E.^. TermStart ]
       let courseCount :: E.SqlExpr (E.Value Int)
           courseCount = E.sub_select . E.from $ \course -> do
             E.where_ $ term E.^. TermId E.==. course E.^. CourseTermId

src/Handler/Utils/Table/Pagination.hs

@@ -3,30 +3,51 @@
            , RecordWildCards
            , OverloadedStrings
            , TemplateHaskell
+           , QuasiQuotes
            , LambdaCase
            , ViewPatterns
   #-}
 
-module Handler.Utils.Table.Pagination where
+module Handler.Utils.Table.Pagination
+  ( SortColumn(..), SortDirection(..)
+  , DBTable(..)
+  , PaginationSettings(..)
+  , PSValidator(..)
+  , dbTable
+  ) where
 
 import Import
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect)
 import Text.Blaze (Attribute)
+import qualified Text.Blaze.Html5.Attributes as Html5
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
 
 import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_)
 
-import Data.Map (Map)
+import Data.Map (Map, (!))
 
 import Colonnade hiding (bool, fromMaybe)
 import Yesod.Colonnade
 
 import Text.Hamlet (hamletFile)
 
+import Data.Ratio ((%))
+
 
 data SortColumn = forall a. PersistField a => SortColumn { getSortColumn :: E.SqlExpr (E.Value a) }
+
 data SortDirection = SortAsc | SortDesc
   deriving (Eq, Ord, Enum, Show, Read)
+instance PathPiece SortDirection where
+  toPathPiece SortAsc  = "asc"
+  toPathPiece SortDesc = "desc"
+  fromPathPiece (CI.mk -> t)
+    | t == "asc"  = Just SortAsc
+    | t == "desc" = Just SortDesc
+    | otherwise   = Nothing
 
 sqlSortDirection :: (SortColumn, SortDirection) -> E.SqlExpr E.OrderBy
 sqlSortDirection (SortColumn e, SortAsc ) = E.asc  e
@@ -45,7 +66,7 @@ data DBTable = forall a r h i.
   }
 
 data PaginationSettings = PaginationSettings
-  { psSorting      :: [(SortColumn, SortDirection)]
+  { psSorting      :: [(Text, SortDirection)]
   , psLimit        :: Int64
   , psPage         :: Int64
   , psShortcircuit :: Bool
@@ -74,23 +95,21 @@ dbTable :: PSValidator -> DBTable -> Handler Widget
 dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do
   let
     sortingOptions = mkOptionList
-      [ Option t' (c, d) t'
-      | (t, c) <- mapToList dbtSorting
+      [ Option t' (t, d) t'
+      | (t, _) <- mapToList dbtSorting
       , d <- [SortAsc, SortDesc]
-      , let t' = t <> "-" <> tshow d
+      , let t' = t <> "-" <> toPathPiece d
       ]
-    sortingField = Field parse (\_ _ _ _ _ -> return ()) UrlEncoded
-      where
-        parse optlist _ = case mapM (olReadExternal sortingOptions) optlist of
-          Nothing -> return $ Left "Error parsing values"
-          Just res -> return $ Right $ Just res
     (_, defPS) = runPSValidator Nothing
     wIdent n
       | not $ null dbtIdent = dbtIdent <> "-" <> n
       | otherwise           = n
+    dbtAttrs'
+      | not $ null dbtIdent = Html5.id (fromString $ unpack dbtIdent) <> dbtAttrs
+      | otherwise           = dbtAttrs
     
   psResult <- runInputGetResult $ PaginationSettings
-    <$> ireq sortingField (wIdent "sorting")
+    <$> ireq (multiSelectField $ return sortingOptions) (wIdent "sorting")
     <*> (fromMaybe (psLimit defPS) <$> iopt intField (wIdent "pagesize"))
     <*> (fromMaybe (psPage  defPS) <$> iopt intField (wIdent "page"))
     <*> ireq checkBoxField (wIdent "table-only")
@@ -105,17 +124,22 @@ dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do
       FormSuccess ps   -> runPSValidator $ Just ps
       FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator Nothing
       FormMissing      -> runPSValidator Nothing
+    psSorting' = map (first (dbtSorting !)) psSorting
     sqlQuery' = dbtSQLQuery
-      <* E.orderBy (map sqlSortDirection psSorting)
+      <* E.orderBy (map sqlSortDirection psSorting')
       <* E.limit psLimit
       <* E.offset (psPage * psLimit)
 
   mapM_ (addMessageI "warning") errs
-     
-  rows <- runDB $ E.select sqlQuery'
+
+  (rows, [E.Value rowCount]) <- runDB $ (,) <$> E.select sqlQuery' <*> E.select (E.countRows <$ dbtSQLQuery :: E.SqlQuery (E.SqlExpr (E.Value Int64)))
 
   bool return (sendResponse <=< tblLayout) psShortcircuit $ do
-    encodeCellTable dbtAttrs dbtColonnade rows
+    let table = encodeCellTable dbtAttrs' dbtColonnade rows
+        pageCount = max 1 . ceiling $ rowCount % psLimit
+    $(widgetFile "table-layout")
   where
     tblLayout :: Widget -> Handler Html
-    tblLayout = widgetToPageContent >=> (\tbl -> withUrlRenderer $(hamletFile "templates/table-layout.hamlet"))
+    tblLayout tbl' = do
+      tbl <- widgetToPageContent tbl'
+      withUrlRenderer $(hamletFile "templates/table-layout-wrapper.hamlet")

templates/table-layout-wrapper.hamlet

@@ -0,0 +1 @@
+^{pageBody tbl}

templates/table-layout.hamlet

@@ -1 +1,4 @@
-^{pageBody tbl}
+<div .table>
+  ^{table}
+  <p style="text-align:center">
+    _{MsgPage (succ psPage) pageCount}