Merge branch 'master' into initial_thoughts_on_frontend

messages/de.msg

@@ -1,2 +1,3 @@
 SummerTerm year@Integer: Sommersemester #{tshow year}
-WinterTerm year@Integer: Wintersemester #{tshow year}/#{tshow $ succ year}
+WinterTerm year@Integer: Wintersemester #{tshow year}/#{tshow $ succ year}
+PSLimitNonPositive: “pagesize” muss größer als null sein

src/Handler/Term.hs

@@ -28,18 +28,19 @@ getTermShowR = do
 --              E.orderBy [E.desc $ term E.^. TermStart ]
 --              return term
 --
-  termData <- runDB $ E.select . E.from $ \term -> do
-    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
-          return E.countRows
-    return (term, courseCount)
+  let
+    termData = E.from $ \term -> do
+      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
+            return E.countRows
+      return (term, courseCount)
   selectRep $ do
-    provideRep $ return $ toJSON $ map fst termData
+    provideRep $ toJSON . map fst <$> runDB (E.select termData)
     provideRep $ do
       let colonnadeTerms = mconcat
-            [ headed "Kürzel" $ \(Entity tid Term{..},_) -> do
+            [ headed "Kürzel" $ \(Entity tid Term{..},_) -> cell $ do
                 -- Scrap this if to slow, create term edit page instead
                 adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False
                 [whamlet|
@@ -50,27 +51,33 @@ getTermShowR = do
                       #{termToText termName}
                 |]
             , headed "Beginn Vorlesungen" $ \(Entity _ Term{..},_) ->
-                fromString $ formatTimeGerWD termLectureStart
+                stringCell $ formatTimeGerWD termLectureStart
             , headed "Ende Vorlesungen"   $ \(Entity _ Term{..},_) ->
-                fromString $ formatTimeGerWD termLectureEnd
+                stringCell $ formatTimeGerWD termLectureEnd
             , headed "Aktiv" $ \(Entity _ Term{..},_) ->
-                bool "" tickmark termActive
+                textCell $ bool "" tickmark termActive
             , headed "Kursliste" $ \(Entity tid Term{..}, E.Value numCourses) ->
-                [whamlet|
+                cell [whamlet|
                   <a href=@{CourseListTermR tid}>
                     #{show numCourses} Kurse
                 |]
             , headed "Semesteranfang" $ \(Entity _ Term{..},_) ->
-              fromString $ formatTimeGerWD termStart
+              stringCell $ formatTimeGerWD termStart
             , headed "Semesterende"   $ \(Entity _ Term{..},_) ->
-              fromString $ formatTimeGerWD termEnd
+              stringCell $ formatTimeGerWD termEnd
             , headed "Feiertage im Semester" $ \(Entity _ Term{..},_) ->
-              fromString $ (intercalate ", ") $ map formatTimeGerWD termHolidays
+              stringCell $ (intercalate ", ") $ map formatTimeGerWD termHolidays
             ]
+      table <- dbTable def $ DBTable
+        { dbtSQLQuery = termData
+        , dbtColonnade = colonnadeTerms
+        , dbtSorting = mempty
+        , dbtAttrs = tableDefault
+        , dbtIdent = "terms" :: Text
+        }
       defaultLayout $ do
         setTitle "Freigeschaltete Semester"
-        encodeWidgetTable tableSortable colonnadeTerms termData
-
+        table
 
 getTermEditR :: Handler Html
 getTermEditR = do

src/Handler/Utils.hs

@@ -13,6 +13,7 @@ import Handler.Utils.DateTime as Handler.Utils
 import Handler.Utils.Term as Handler.Utils
 import Handler.Utils.Form as Handler.Utils
 import Handler.Utils.Table as Handler.Utils
+import Handler.Utils.Table.Pagination as Handler.Utils
 
 import Handler.Utils.Zip as Handler.Utils
 import Handler.Utils.Rating as Handler.Utils

src/Handler/Utils/Table/Pagination.hs

@@ -0,0 +1,121 @@
+{-# LANGUAGE NoImplicitPrelude
+           , ExistentialQuantification
+           , RecordWildCards
+           , OverloadedStrings
+           , TemplateHaskell
+           , LambdaCase
+           , ViewPatterns
+  #-}
+
+module Handler.Utils.Table.Pagination where
+
+import Import
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect)
+import Text.Blaze (Attribute)
+
+import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_)
+
+import Data.Map (Map)
+
+import Colonnade hiding (bool, fromMaybe)
+import Yesod.Colonnade
+
+import Text.Hamlet (hamletFile)
+
+
+data SortColumn = forall a. PersistField a => SortColumn { getSortColumn :: E.SqlExpr (E.Value a) }
+data SortDirection = SortAsc | SortDesc
+  deriving (Eq, Ord, Enum, Show, Read)
+
+sqlSortDirection :: (SortColumn, SortDirection) -> E.SqlExpr E.OrderBy
+sqlSortDirection (SortColumn e, SortAsc ) = E.asc  e
+sqlSortDirection (SortColumn e, SortDesc) = E.desc e
+  
+data DBTable = forall a r h i.
+  ( Headedness h
+  , E.SqlSelect a r
+  , PathPiece i
+  ) => DBTable
+  { dbtSQLQuery :: E.SqlQuery a
+  , dbtColonnade :: Colonnade h r (Cell UniWorX)
+  , dbtSorting :: Map Text SortColumn
+  , dbtAttrs :: Attribute
+  , dbtIdent :: i
+  }
+
+data PaginationSettings = PaginationSettings
+  { psSorting      :: [(SortColumn, SortDirection)]
+  , psLimit        :: Int64
+  , psPage         :: Int64
+  , psShortcircuit :: Bool
+  }
+
+instance Default PaginationSettings where
+  def = PaginationSettings
+    { psSorting      = []
+    , psLimit        = 50
+    , psPage         = 0
+    , psShortcircuit = False
+    }
+
+newtype PSValidator = PSValidator { runPSValidator :: Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) }
+
+instance Default PSValidator where
+  def = PSValidator $ \case
+    Nothing -> def
+    Just ps -> swap . (\act -> execRWS act () ps) $ do
+      l <- gets psLimit
+      when (l <= 0) $ do
+        modify $ \ps -> ps { psLimit = psLimit def }
+        tell . pure $ SomeMessage MsgPSLimitNonPositive
+
+dbTable :: PSValidator -> DBTable -> Handler Widget
+dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do
+  let
+    sortingOptions = mkOptionList
+      [ Option t' (c, d) t'
+      | (t, c) <- mapToList dbtSorting
+      , d <- [SortAsc, SortDesc]
+      , let t' = t <> "-" <> tshow 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
+    
+  psResult <- runInputGetResult $ PaginationSettings
+    <$> ireq sortingField (wIdent "sorting")
+    <*> (fromMaybe (psLimit defPS) <$> iopt intField (wIdent "pagesize"))
+    <*> (fromMaybe (psPage  defPS) <$> iopt intField (wIdent "page"))
+    <*> ireq checkBoxField (wIdent "table-only")
+
+  $(logDebug) . tshow $ (,,,) <$> (length . psSorting <$> psResult)
+                              <*> (psLimit <$> psResult)
+                              <*> (psPage <$> psResult)
+                              <*> (psShortcircuit <$> psResult)
+
+  let
+    (errs, PaginationSettings{..}) = case psResult of
+      FormSuccess ps   -> runPSValidator $ Just ps
+      FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator Nothing
+      FormMissing      -> runPSValidator Nothing
+    sqlQuery' = dbtSQLQuery
+      <* E.orderBy (map sqlSortDirection psSorting)
+      <* E.limit psLimit
+      <* E.offset (psPage * psLimit)
+
+  mapM_ (addMessageI "warning") errs
+     
+  rows <- runDB $ E.select sqlQuery'
+
+  bool return (sendResponse <=< tblLayout) psShortcircuit $ do
+    encodeCellTable dbtAttrs dbtColonnade rows
+  where
+    tblLayout :: Widget -> Handler Html
+    tblLayout = widgetToPageContent >=> (\tbl -> withUrlRenderer $(hamletFile "templates/table-layout.hamlet"))

templates/table-layout.hamlet

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