diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs
index 5deecac7e..2461a05fc 100644
--- a/src/Handler/Term.hs
+++ b/src/Handler/Term.hs
@@ -42,7 +42,7 @@ getTermShowR = do
provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData)
provideRep $ do
let colonnadeTerms = mconcat
- [ headed "Kürzel" $ \(Entity tid Term{..},_) -> cell $ do
+ [ sortable Nothing "Kürzel" $ \(Entity tid Term{..},_) -> cell $ do
-- Scrap this if to slow, create term edit page instead
adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False
[whamlet|
@@ -52,22 +52,22 @@ getTermShowR = do
$else
#{termToText termName}
|]
- , headed "Beginn Vorlesungen" $ \(Entity _ Term{..},_) ->
+ , sortable (Just "lecture-start") "Beginn Vorlesungen" $ \(Entity _ Term{..},_) ->
stringCell $ formatTimeGerWD termLectureStart
- , headed "Ende Vorlesungen" $ \(Entity _ Term{..},_) ->
+ , sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) ->
stringCell $ formatTimeGerWD termLectureEnd
- , headed "Aktiv" $ \(Entity _ Term{..},_) ->
+ , sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) ->
textCell $ bool "" tickmark termActive
- , headed "Kursliste" $ \(Entity tid Term{..}, E.Value numCourses) ->
+ , sortable Nothing "Kursliste" $ \(Entity tid Term{..}, E.Value numCourses) ->
cell [whamlet|
#{show numCourses} Kurse
|]
- , headed "Semesteranfang" $ \(Entity _ Term{..},_) ->
+ , sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) ->
stringCell $ formatTimeGerWD termStart
- , headed "Semesterende" $ \(Entity _ Term{..},_) ->
+ , sortable (Just "end") "Semesterende" $ \(Entity _ Term{..},_) ->
stringCell $ formatTimeGerWD termEnd
- , headed "Feiertage im Semester" $ \(Entity _ Term{..},_) ->
+ , sortable Nothing "Feiertage im Semester" $ \(Entity _ Term{..},_) ->
stringCell $ (intercalate ", ") $ map formatTimeGerWD termHolidays
]
table <- dbTable def $ DBTable
diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs
index 23f0b6608..6f0c1d4c5 100644
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/src/Handler/Utils/Table/Pagination.hs
@@ -14,15 +14,24 @@ module Handler.Utils.Table.Pagination
, DBTable(..)
, PaginationSettings(..)
, PSValidator(..)
+ , Sortable(..), sortable
, dbTable
) where
+import Handler.Utils.Table.Pagination.Types
+
import Import
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect)
import qualified Database.Esqueleto.Internal.Language as E (From)
import Text.Blaze (Attribute)
import qualified Text.Blaze.Html5.Attributes as Html5
+import qualified Text.Blaze.Html5 as Html5
+import Yesod.Core.Types (Body(..),GWData(..),WidgetT(..))
+
+import qualified Data.Binary.Builder as Builder
+
+import qualified Network.Wai as Wai
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
@@ -32,6 +41,7 @@ import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_)
import Data.Map (Map, (!))
import Colonnade hiding (bool, fromMaybe)
+import Colonnade.Encode
import Yesod.Colonnade
import Text.Hamlet (hamletFile)
@@ -56,7 +66,7 @@ sqlSortDirection t (SortColumn e, SortAsc ) = E.asc $ e t
sqlSortDirection t (SortColumn e, SortDesc) = E.desc $ e t
data DBTable = forall a r h i t.
- ( Headedness h
+ ( ToSortable h
, E.SqlSelect a r
, PathPiece i
, E.From E.SqlQuery E.SqlExpr E.SqlBackend t
@@ -94,6 +104,7 @@ instance Default PSValidator where
modify $ \ps -> ps { psLimit = psLimit def }
tell . pure $ SomeMessage MsgPSLimitNonPositive
+
dbTable :: PSValidator -> DBTable -> Handler Widget
dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do
let
@@ -138,11 +149,40 @@ dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do
(rows, [E.Value rowCount]) <- runDB $ (,) <$> E.select sqlQuery' <*> E.select (E.countRows <$ E.from dbtSQLQuery :: E.SqlQuery (E.SqlExpr (E.Value Int64)))
bool return (sendResponse <=< tblLayout) psShortcircuit $ do
- let table = encodeCellTable dbtAttrs' dbtColonnade rows
+ getParams <- handlerToWidget $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
+ let table = $(widgetFile "table/table")
pageCount = max 1 . ceiling $ rowCount % psLimit
- $(widgetFile "table-layout")
+ tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
+ withSortLinks Sortable{ sortableContent = Cell{..}, .. } = Cell
+ { cellContents = $(widgetFile "table/sortable-header")
+ , ..
+ }
+ $(widgetFile "table/layout")
where
tblLayout :: Widget -> Handler Html
tblLayout tbl' = do
tbl <- widgetToPageContent tbl'
- withUrlRenderer $(hamletFile "templates/table-layout-wrapper.hamlet")
+ withUrlRenderer $(hamletFile "templates/table/layout-wrapper.hamlet")
+
+ setParam :: Text -> Maybe Text -> QueryText -> QueryText
+ setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ]
+
+widgetFromCell ::
+ (Attribute -> WidgetT site IO () -> WidgetT site IO ())
+ -> Cell site
+ -> WidgetT site IO ()
+widgetFromCell f (Cell attrs contents) =
+ f attrs contents
+td,th ::
+ Attribute -> WidgetT site IO () -> WidgetT site IO ()
+
+td = liftParent Html5.td
+th = liftParent Html5.th
+
+liftParent :: (Html -> Html) -> Attribute -> WidgetT site IO a -> WidgetT site IO a
+liftParent el attrs (WidgetT f) = WidgetT $ \hdata -> do
+ (a,gwd) <- f hdata
+ let Body bodyFunc = gwdBody gwd
+ newBodyFunc render =
+ el Html5.! attrs $ (bodyFunc render)
+ return (a,gwd { gwdBody = Body newBodyFunc })
diff --git a/src/Handler/Utils/Table/Pagination/Types.hs b/src/Handler/Utils/Table/Pagination/Types.hs
new file mode 100644
index 000000000..c2038c4d0
--- /dev/null
+++ b/src/Handler/Utils/Table/Pagination/Types.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE NoImplicitPrelude
+ , ExistentialQuantification
+ , RankNTypes
+ , RecordWildCards
+ #-}
+
+module Handler.Utils.Table.Pagination.Types where
+
+import Import hiding (singleton)
+
+import Colonnade
+import Colonnade.Encode
+
+data Sortable a = Sortable
+ { sortableKey :: (Maybe Text)
+ , sortableContent :: a
+ }
+
+sortable :: Maybe Text -> c -> (a -> c) -> Colonnade Sortable a c
+sortable k h = singleton (Sortable k h)
+
+instance Headedness Sortable where
+ headednessPure = Sortable Nothing
+ headednessExtract = Just $ \(Sortable _ x) -> x
+ headednessExtractForall = Just $ ExtractForall (\(Sortable _ x) -> x)
+
+newtype SortableP s = SortableP { toSortable :: forall a. s a -> Sortable a}
+
+class Headedness s => ToSortable s where
+ pSortable :: Maybe (SortableP s)
+
+instance ToSortable Sortable where
+ pSortable = Just $ SortableP id
+
+instance ToSortable Headed where
+ pSortable = Just $ SortableP (\(Headed x) -> Sortable Nothing x)
+
+instance ToSortable Headless where
+ pSortable = Nothing
+
diff --git a/templates/table-layout-wrapper.hamlet b/templates/table/layout-wrapper.hamlet
similarity index 100%
rename from templates/table-layout-wrapper.hamlet
rename to templates/table/layout-wrapper.hamlet
diff --git a/templates/table-layout.hamlet b/templates/table/layout.hamlet
similarity index 100%
rename from templates/table-layout.hamlet
rename to templates/table/layout.hamlet
diff --git a/templates/table/sortable-header.hamlet b/templates/table/sortable-header.hamlet
new file mode 100644
index 000000000..1054b1ce0
--- /dev/null
+++ b/templates/table/sortable-header.hamlet
@@ -0,0 +1,7 @@
+^{cellContents}
+$maybe flag <- sortableKey
+
+ "-asc")}>asc
+ /
+ "-desc")}>desc
+$nothing
diff --git a/templates/table/table.hamlet b/templates/table/table.hamlet
new file mode 100644
index 000000000..b1de810bf
--- /dev/null
+++ b/templates/table/table.hamlet
@@ -0,0 +1,12 @@
+