Merge remote-tracking branch 'origin/master' into feat/exercises

fill-db.hs

@@ -75,9 +75,10 @@ main = db $ do
   void . insert $ UserLecturer gkleen ifi
   void . insert $ UserLecturer fhamann ifi
   void . insert $ UserLecturer jost ifi
-  ifiBsc <- insert $ Degree "Bachelor Informatik" ifi
-  ifiMsc <- insert $ Degree "Master Informatik" ifi
-  miBsc <- insert $ Degree "Bachelor Mathematik" mi
+  sdBsc  <- insert $ StudyDegree 82 (Just "BSc") (Just "Bachelor"  )
+  sdMst  <- insert $ StudyDegree 88 (Just "MSc") (Just "Master"    )
+  sdInf  <- insert $ StudyTerms  79 (Just "Inf") (Just "Informatik")
+  sdMath <- insert $ StudyTerms 105 (Just "M"  ) (Just "Mathematik")
   -- FFP
   ffp <- insert Course
     { courseName = "Fortgeschrittene Funktionale Programmierung"
@@ -92,8 +93,9 @@ main = db $ do
     , courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now )
     }
   insert_ $ CourseEdit jost now ffp
-  void . insert $ DegreeCourse ifiBsc ffp
-  void . insert $ DegreeCourse ifiMsc ffp
+  void . insert $ DegreeCourse ffp sdBsc sdInf
+  void . insert $ DegreeCourse ffp sdMst sdInf
+  void . insert $ Lecturer jost   ffp
   void . insert $ Lecturer gkleen ffp
   insert_ $ Corrector gkleen ffp (ByProportion 1)
   sheetkey <- insert $ Sheet ffp "Blatt 1" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing
@@ -112,8 +114,7 @@ main = db $ do
     , courseRegisterTo = Nothing
     }
   insert_ $ CourseEdit fhamann now eip
-  void . insert $ DegreeCourse ifiBsc eip
-  void . insert $ DegreeCourse ifiMsc eip
+  void . insert $ DegreeCourse eip sdBsc sdInf
   void . insert $ Lecturer fhamann eip
   -- interaction design
   ixd <- insert Course
@@ -129,7 +130,7 @@ main = db $ do
     , courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now )
     }
   insert_ $ CourseEdit fhamann now ixd
-  void . insert $ DegreeCourse ifiBsc ixd
+  void . insert $ DegreeCourse ixd sdBsc sdInf
   void . insert $ Lecturer fhamann ixd
   -- concept development
   ux3 <- insert Course
@@ -145,7 +146,7 @@ main = db $ do
     , courseRegisterTo = Nothing
     }
   insert_ $ CourseEdit fhamann now ux3
-  void . insert $ DegreeCourse ifiBsc ux3
+  void . insert $ DegreeCourse ux3 sdBsc sdInf
   void . insert $ Lecturer fhamann ux3
   -- promo
   pmo <- insert Course
@@ -161,7 +162,7 @@ main = db $ do
     , courseRegisterTo = Nothing
     }
   insert_ $ CourseEdit jost now pmo
-  void . insert $ DegreeCourse ifiBsc pmo
+  void . insert $ DegreeCourse pmo sdBsc sdInf
   void . insert $ Lecturer jost pmo
   -- datenbanksysteme
   dbs <- insert Course
@@ -177,6 +178,7 @@ main = db $ do
     , courseRegisterTo = Nothing
     }
   insert_ $ CourseEdit gkleen now dbs
-  void . insert $ DegreeCourse ifiBsc dbs
+  void . insert $ DegreeCourse dbs sdBsc sdInf
+  void . insert $ DegreeCourse dbs sdBsc sdMath
   void . insert $ Lecturer gkleen dbs
   void . insert $ Lecturer jost   dbs

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}