Merge branch 'master' into feat/exercises

messages/de.msg

@@ -3,6 +3,7 @@ BtnAbort: Abbrechen
 BtnDelete: Löschen
 BtnRegister: Anmelden
 BtnDeregister: Abmelden
+BtnHijack: Sitzung übernehmen
 
 RegisterFrom: Anmeldungen von
 RegisterTo: Anmeldungen bis
@@ -187,4 +188,11 @@ RatingFilesUpdated: Korrigierte Dateien überschrieben
 
 CourseMembers: Teilnehmer
 CourseMembersCount num@Int64: #{display num}
-CourseMembersCountLimited num@Int64 max@Int64: #{display num}/#{display max}
+CourseMembersCountLimited num@Int64 max@Int64: #{display num}/#{display max}
+
+NoTableContent: Kein Tabelleninhalt
+NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter
+
+AdminFor: Administrator
+LecturerFor: Dozent
+UserListTitle: Komprehensive Benutzerliste

models

@@ -12,6 +12,7 @@ User json
 UserAdmin
     user   UserId
     school SchoolId
+    UniqueUserAdmin user school
 UserLecturer
     user   UserId
     school SchoolId

routes

@@ -35,6 +35,7 @@
 /users                      UsersR            GET             -- no tags, i.e. admins only
 /admin/test                 AdminTestR        GET POST
 /admin/user/#CryptoUUIDUser AdminUserR        GET
+/admin/user/#CryptoUUIDUser/hijack AdminHijackUserR POST
 /info                       VersionR          GET             !free
 
 /profile                    ProfileR          GET POST        !free                             !free

src/Foundation.hs

@@ -459,7 +459,6 @@ instance Yesod UniWorX where
     defaultLayout widget = do
         master <- getYesod
         mmsgs  <- getMessages
-        messageRender <- getMessageRender -- needed, since there is no i18n interpolation in Julius
 
         mcurrentRoute <- getCurrentRoute
 
@@ -493,10 +492,10 @@ instance Yesod UniWorX where
                in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute)
 
         let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority
-            highlight = let crumbs = mcons mcurrentRoute $ fst <$> parents
+            highlight = let crumbs = mcons mcurrentRoute $ fst <$> reverse parents
-                            actFav = List.intersect (snd3 <$> favourites) crumbs
+                            navItems = map snd3 favourites ++ map (menuItemRoute . menuItem) menuTypes
-                            highRs = if null actFav then crumbs else actFav
+                            highR  = find (`elem` navItems) . uncurry (++) $ partition (`elem` map snd3 favourites) crumbs
-                        in \r -> r `elem` highRs
+                        in \r -> Just r == highR
             favouriteTerms :: [TermIdentifier]
             favouriteTerms = Set.toDescList $ foldMap (\(Course{..}, _, _) -> Set.singleton $ unTermKey courseTerm) favourites
             favouriteTerm :: TermIdentifier -> [(Course, Route UniWorX, [MenuTypes])]
@@ -655,7 +654,7 @@ submissionList tid csh shn uid = E.select . E.from $ \(course `E.InnerJoin` shee
 
 defaultLinks :: [MenuTypes]
 defaultLinks = -- Define the menu items of the header.
-  [ NavbarRight $ MenuItem
+  [ NavbarAside $ MenuItem
       { menuItemLabel = "Home"
       , menuItemIcon = Just "home"
       , menuItemRoute = HomeR

src/Handler/Corrections.hs

@@ -170,7 +170,7 @@ makeCorrectionsTable whereClause colChoices psValidator = do
                                           E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False)
                        )
                      ]
-    , dbtAttrs     = tableDefault
+    , dbtStyle     = def
     , dbtIdent     = "corrections" :: Text
     }
 

src/Handler/Course.hs

@@ -85,7 +85,7 @@ getTermCourseListR tid = do
           )
         ]
     , dbtFilter = mempty
-    , dbtAttrs = tableDefault
+    , dbtStyle = def
     , dbtIdent = "courses" :: Text
     }
   

src/Handler/Home.hs

@@ -95,7 +95,7 @@ homeAnonymous = do
                             | otherwise     -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
                         )
                         ] -}
-    , dbtAttrs     = tableDefault
+    , dbtStyle     = def
     , dbtIdent     = "upcomingdeadlines" :: Text
     }
   let features = $(widgetFile "featureList")
@@ -184,7 +184,7 @@ homeUser uid = do
                             | otherwise     -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
                         )
                         ] -}
-    , dbtAttrs     = tableDefault
+    , dbtStyle     = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
     , dbtIdent     = "upcomingdeadlines" :: Text
     }
   defaultLayout $ do

src/Handler/Sheet.hs

@@ -232,7 +232,7 @@ getSShowR tid csh shn = do
   fileTable <- dbTable def $ DBTable
     { dbtSQLQuery = fileData
     , dbtColonnade = colonnadeFiles
-    , dbtAttrs = tableDefault
+    , dbtStyle = def
     , dbtFilter = Map.empty
     , dbtIdent = "files" :: Text
     -- TODO: Add column for and visibility date

src/Handler/Submission.hs

@@ -288,7 +288,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
       smid2ArchiveTable (smid,cid) = DBTable
         { dbtSQLQuery = submissionFiles smid
         , dbtColonnade = colonnadeFiles cid
-        , dbtAttrs = tableDefault
+        , dbtStyle = def
         , dbtIdent = "files" :: Text
         , dbtSorting =  [ ( "path"
                           , SortColumn $ \((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) -> E.coalesce [f1 E.?. FileTitle, f2 E.?. FileTitle]

src/Handler/Term.hs

@@ -99,7 +99,7 @@ getTermShowR = do
                                    E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs
                         )
                       ]
-        , dbtAttrs = tableDefault
+        , dbtStyle = def
         , dbtIdent = "terms" :: Text
         }
       defaultLayout $ do

src/Handler/Users.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module Handler.Users where
 
@@ -11,39 +12,100 @@ import Import
 -- import Data.Text
 import Handler.Utils
 
-import Colonnade hiding (fromMaybe)
+import qualified Data.Map as Map
-import Yesod.Colonnade
+import qualified Data.Set as Set
 
--- import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto as E
--- import           Database.Esqueleto      ((^.))
 
 
+hijackUserForm :: UserId -> Form UserId
+hijackUserForm uid csrf = do
+  cID <- encrypt uid
+  (uidResult, uidView) <- mforced hiddenField "" (cID :: CryptoUUIDUser)
+  (btnResult, btnView) <- mreq (buttonField BtnHijack) "" Nothing 
+
+  return (uid <$ uidResult <* btnResult, mconcat [toWidget csrf, fvInput uidView, fvInput btnView])
+
 getUsersR :: Handler Html
 getUsersR = do
-  -- TODO: Esqueleto, combine the two queries into one
+  let
-  (users,schools) <- runDB $ (,)
+    colonnadeUsers = dbColonnade . mconcat $
-    <$> (selectList [] [Asc UserDisplayName]
+      [ dbRow
-        >>= mapM (\usr -> (,,)
+      , sortable (Just "display-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
-          <$> pure usr
+          (AdminUserR <$> encrypt uid)
-          <*> selectList [UserAdminUser    ==. entityKey usr] [Asc UserAdminSchool]
+          (toWidget . display $ userDisplayName)
-          <*> selectList [UserLecturerUser ==. entityKey usr] [Asc UserLecturerSchool]
+      , sortable Nothing (i18nCell MsgAdminFor) $ \DBRow{ dbrOutput = Entity uid _ } -> mempty
-        ))
+          { dbCellContents = do
-    <*> selectList [] [Asc SchoolShorthand]
+              schools <- E.select . E.from $ \(school `E.InnerJoin` userAdmin) -> do
-  let schoolnames = entities2map schools
+                E.on $ school E.^. SchoolId E.==. userAdmin E.^. UserAdminSchool
-  let getSchoolname = \sid ->
+                E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid
-        case lookup sid schoolnames of
+                E.orderBy [E.asc $ school E.^. SchoolShorthand]
-          Nothing -> "???"
+                return $ school E.^. SchoolShorthand
-          (Just school) -> schoolShorthand school
+              return [whamlet|
-  let colonnadeUsers = mconcat $
+                  <ul .list--inline .list--comma-separated>
-        [ headed "User" $ \u -> do
+                    $forall (E.Value sh) <- schools
-            cID <- encrypt $ entityKey $ fst3 u
+                      <li>#{sh}
-            let name = display $ userDisplayName $ entityVal $ fst3 u
+                |]
-            [whamlet|<a href=@{AdminUserR cID}>#{name}|]
+          }
-        , headed "Admin"   $ (\u -> text2widget $ intercalate ", " $ map (getSchoolname.userAdminSchool   .entityVal) $ snd3 u)
+      , sortable Nothing (i18nCell MsgLecturerFor) $ \DBRow{ dbrOutput = Entity uid _ } -> mempty
-        , headed "Lecturer" $ (\u -> text2widget $ intercalate ", " $ map (getSchoolname.userLecturerSchool.entityVal) $ trd3 u)
+          { dbCellContents = do
+              schools <- E.select . E.from $ \(school `E.InnerJoin` userLecturer) -> do
+                E.on $ school E.^. SchoolId E.==. userLecturer E.^. UserLecturerSchool
+                E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid
+                E.orderBy [E.asc $ school E.^. SchoolShorthand]
+                return $ school E.^. SchoolShorthand
+              return [whamlet|
+                  <ul .list--inline .list--comma-separated>
+                    $forall (E.Value sh) <- schools
+                      <li>#{sh}
+                |]
+          }
+      , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity uid _ } -> cell $ do
+          (hijackView, hijackEnctype) <- liftHandlerT . generateFormPost $ hijackUserForm uid
+          cID <- encrypt uid
+          [whamlet|
+            <form method=POST action=@{AdminHijackUserR cID} enctype=#{hijackEnctype}>
+              ^{hijackView}
+          |]
+      ]
+    psValidator = def
+      & defaultSorting [("display-name", SortAsc)]
+  
+  userList <- dbTable psValidator $ DBTable
+    { dbtSQLQuery  = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
+    , dbtColonnade = colonnadeUsers
+    , dbtSorting   = Map.fromList
+        [ ( "display-name"
+          , SortColumn $ \user -> user E.^. UserDisplayName
+          )
         ]
-        -- ++  map (\school -> headed (text2widget $ schoolName $ entityVal school) (\u -> "xx")) schools
+    , dbtFilter    = mempty
+    , dbtStyle     = def
+    , dbtIdent     = "users" :: Text
+    }
+  
   defaultLayout $ do
-    setTitle "Comprehensive User List"
+    setTitleI MsgUserListTitle
-    let userList = encodeWidgetTable tableSortable colonnadeUsers users
     $(widgetFile "users")
+
+postAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent
+postAdminHijackUserR cID = do
+  uid <- decrypt cID
+  ((hijackRes, _), _) <- runFormPost $ hijackUserForm uid
+
+  case hijackRes of
+    FormSuccess uid'
+      | uid' == uid -> do
+          myUid <- requireAuthId
+          User{..} <- runDB $ do
+            otherSchoolsAdmin <- Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] []
+            otherSchoolsLecturer <- Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] []
+            mySchools <- Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. myUid] []
+            when (not $ (otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) $
+              permissionDenied "Cannot escalate admin status to additional schools"
+
+            get404 uid
+          setCredsRedirect $ Creds "dummy" (userPlugin <> ":" <> userIdent) []
+      | otherwise -> error "This should be impossible by definition of `hijackUserForm`"
+    FormFailure errs -> toTypedContent <$> mapM_ (addMessage "error" . toHtml) errs
+    FormMissing -> return $ toTypedContent ()

src/Handler/Utils/Form.hs

@@ -142,6 +142,18 @@ instance Button RegisterButton where
   cssClass BtnRegister   = BCPrimary
   cssClass BtnDeregister = BCDanger
 
+data AdminHijackUserButton = BtnHijack
+  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+
+instance PathPiece AdminHijackUserButton where
+  toPathPiece   = showToPathPiece
+  fromPathPiece = readFromPathPiece
+
+instance Button AdminHijackUserButton where
+  label BtnHijack = [whamlet|_{MsgBtnHijack}|]
+
+  cssClass BtnHijack = BCDefault
+
 
 -- -- Looks like a button, but is just a link (e.g. for create course, etc.)
 -- data LinkButton = LinkButton (Route UniWorX)

src/Handler/Utils/Table/Pagination.hs

@@ -21,17 +21,19 @@ module Handler.Utils.Table.Pagination
   ( SortColumn(..), SortDirection(..)
   , FilterColumn(..), IsFilterColumn
   , DBRow(..), DBOutput
-  , DBTable(..), IsDBTable(..)
+  , DBStyle(..), DBEmptyStyle(..)
+  , DBTable(..), IsDBTable(..), DBCell(..)
   , PaginationSettings(..), PaginationInput(..), piIsUnset
   , PSValidator(..)
   , defaultFilter, defaultSorting
   , restrictFilter, restrictSorting
   , ToSortable(..), Sortable(..), sortable
   , dbTable
-  , widgetColonnade, formColonnade
+  , widgetColonnade, formColonnade, dbColonnade
   , textCell, stringCell, i18nCell, anchorCell, anchorCell', anchorCellM
   , formCell, DBFormResult, getDBFormResult
   , dbRow, dbSelect
+  , (&)
   ) where
 
 import Handler.Utils.Table.Pagination.Types
@@ -53,6 +55,7 @@ import qualified Data.CaseInsensitive as CI
 
 import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_, forM_)
 import Control.Monad.Writer hiding ((<>), Foldable(..), mapM_, forM_)
+import Control.Monad.Reader (ReaderT(..), mapReaderT)
 
 import Data.Map (Map, (!))
 import qualified Data.Map as Map
@@ -128,6 +131,25 @@ instance DBOutput (DBRow r) r where
 instance DBOutput (DBRow r) (Int64, r) where
   dbProj = (,) <$> dbrIndex <*> dbrOutput
 
+data DBEmptyStyle = DBESNoHeading | DBESHeading
+  deriving (Enum, Bounded, Ord, Eq, Show, Read)
+
+instance Default DBEmptyStyle where
+  def = DBESHeading
+
+data DBStyle = DBStyle
+  { dbsEmptyStyle :: DBEmptyStyle
+  , dbsEmptyMessage :: UniWorXMessage
+  , dbsAttrs :: [(Text, Text)]
+  }
+
+instance Default DBStyle where
+  def = DBStyle
+    { dbsEmptyStyle = def
+    , dbsEmptyMessage = MsgNoTableContent
+    , dbsAttrs = [ ("class", "table table--striped table--hover table--sortable") ]
+    }
+
 data DBTable m x = forall a r r' h i t.
   ( ToSortable h, Functor h
   , E.SqlSelect a r, DBOutput (DBRow r) r'
@@ -138,7 +160,7 @@ data DBTable m x = forall a r r' h i t.
   , dbtColonnade :: Colonnade h r' (DBCell m x)
   , dbtSorting :: Map (CI Text) (SortColumn t)
   , dbtFilter :: Map (CI Text) (FilterColumn t)
-  , dbtAttrs :: Attribute -- FIXME: currently unused
+  , dbtStyle :: DBStyle
   , dbtIdent :: i
   }
 
@@ -231,18 +253,18 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *)
     
   -- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
   dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Proxy m -> Proxy x -> DBResult m x -> m' Widget
-  runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (x, Widget) -> m' (DBResult m x)
+  runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x)
 
 instance IsDBTable (WidgetT UniWorX IO) () where
   type DBResult (WidgetT UniWorX IO) () = Widget
   -- type DBResult' (WidgetT UniWorX IO) () = ()
 
   data DBCell (WidgetT UniWorX IO) () = WidgetCell
-    { dbCellAttrs :: [(Text, Text)]
+    { wgtCellAttrs :: [(Text, Text)]
-    , dbCellContents :: Widget
+    , wgtCellContents :: Widget
     }
-  cellAttrs = lens dbCellAttrs $ \w as -> w { dbCellAttrs = as }
+  cellAttrs = lens wgtCellAttrs $ \w as -> w { wgtCellAttrs = as }
-  cellContents = return . dbCellContents
+  cellContents = return . wgtCellContents
 
   cell = WidgetCell []
   
@@ -254,6 +276,27 @@ instance Monoid (DBCell (WidgetT UniWorX IO) ()) where
   mempty = WidgetCell mempty mempty
   (WidgetCell a c) `mappend` (WidgetCell a' c') = WidgetCell (mappend a a') (mappend c c')
 
+instance IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) () where
+  type DBResult (ReaderT SqlBackend (HandlerT UniWorX IO)) () = Widget
+
+  data DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) () = DBCell
+    { dbCellAttrs :: [(Text, Text)]
+    , dbCellContents :: ReaderT SqlBackend (HandlerT UniWorX IO) Widget
+    }
+
+  cellAttrs = lens dbCellAttrs $ \w as -> w { dbCellAttrs = as }
+  cellContents = lift . dbCellContents
+
+  cell = DBCell [] . return
+
+  dbWidget Proxy Proxy = return
+  -- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerT UniWorX IO) ((), Widget) -> m (Widget)
+  runDBTable = fmap snd . mapReaderT liftHandlerT
+
+instance Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) ()) where
+  mempty = DBCell mempty $ return mempty
+  (DBCell a c) `mappend` (DBCell a' c') = DBCell (mappend a a') (mappend <$> c <*> c')
+
 instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) where
   -- type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = ((FormResult a, Widget), Enctype)
   type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = Form a
@@ -285,7 +328,7 @@ instance IsDBTable m a => IsString (DBCell m a) where
       
 
 dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> Handler (DBResult m x)
-dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtColonnade = (lmap dbProj -> dbtColonnade), .. }) = do
+dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtColonnade = (lmap dbProj -> dbtColonnade), dbtStyle = DBStyle{..}, .. }) = do
   let
     sortingOptions = mkOptionList
       [ Option t' (t, d) t'
@@ -297,9 +340,9 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
     wIdent n
       | not $ null dbtIdent = dbtIdent <> "-" <> n
       | otherwise           = n
-    dbtAttrs'
+    dbsAttrs'
-      | not $ null dbtIdent = Html5.id (fromString $ unpack dbtIdent) <> dbtAttrs
+      | not $ null dbtIdent = ("id", dbtIdent) : dbsAttrs
-      | otherwise           = dbtAttrs
+      | otherwise           = dbsAttrs
     multiTextField = Field
       { fieldParse = \ts _ -> return . Right $ Just ts
       , fieldView = undefined
@@ -334,54 +377,55 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
 
   mapM_ (addMessageI "warning") errs
 
-  rows' <- runDB . E.select $ (,) <$> pure (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64)) <*> sqlQuery'
+  runDB $ do
+    rows' <- E.select $ (,) <$> pure (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64)) <*> sqlQuery'
 
-  let
+    let
-    rowCount
+      rowCount
-      | (E.Value n, _):_ <- rows' = n
+        | (E.Value n, _):_ <- rows' = n
-      | otherwise = 0
+        | otherwise = 0
-    rows = map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows'
+      rows = map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows'
 
-    table' :: WriterT x m Widget
+      table' :: WriterT x m Widget
-    table' = do
+      table' = do
-      getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
+        getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
 
-      let
+        let
-        tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
+          tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
 
-        genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
+          genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
-          widget <- cellContents sortableContent
+            widget <- cellContents sortableContent
-          let
+            let
-            directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ]
+              directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ]
-            isSortable = isJust sortableKey
+              isSortable = isJust sortableKey
-            isSorted = (`elem` directions)
+              isSorted = (`elem` directions)
-            attrs = sortableContent ^. cellAttrs
+              attrs = sortableContent ^. cellAttrs
-          return $(widgetFile "table/cell/header")
+            return $(widgetFile "table/cell/header")
 
-        columnCount :: Int64
+          columnCount :: Int64
-        columnCount = olength64 $ getColonnade dbtColonnade
+          columnCount = olength64 $ getColonnade dbtColonnade
 
-      wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable
+        wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable
 
-      wRows <- forM rows $ \row -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row) -> cell) -> do
+        wRows <- forM rows $ \row -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row) -> cell) -> do
-        widget <- cellContents cell
+          widget <- cellContents cell
-        let attrs = cell ^. cellAttrs
+          let attrs = cell ^. cellAttrs
-        return $(widgetFile "table/cell/body")
+          return $(widgetFile "table/cell/body")
       
-      let table = $(widgetFile "table/colonnade")
+        let table = $(widgetFile "table/colonnade")
-          pageCount = max 1 . ceiling $ rowCount % psLimit
+            pageCount = max 1 . ceiling $ rowCount % psLimit
-          pageNumbers = [0..pred pageCount]
+            pageNumbers = [0..pred pageCount]
 
-      return $(widgetFile "table/layout")
+        return $(widgetFile "table/layout")
+    
+      dbWidget' :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBResult m x -> m' Widget
+      dbWidget' = dbWidget (Proxy :: Proxy m) (Proxy :: Proxy x)
 
-    dbWidget' :: DBResult m x -> Handler Widget
+    bool return (sendResponse <=< tblLayout <=< dbWidget') psShortcircuit <=< runDBTable . fmap swap $ runWriterT table'
-    dbWidget' = dbWidget (Proxy :: Proxy m) (Proxy :: Proxy x)
-
-  bool return (sendResponse <=< tblLayout <=< dbWidget') psShortcircuit <=< runDBTable . fmap swap $ runWriterT table'
   where
-    tblLayout :: Widget -> Handler Html
+    tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html
     tblLayout tbl' = do
-      tbl <- widgetToPageContent tbl'
+      tbl <- liftHandlerT $ widgetToPageContent tbl'
       withUrlRenderer $(hamletFile "templates/table/layout-wrapper.hamlet")
 
     setParam :: Text -> Maybe Text -> QueryText -> QueryText
@@ -399,6 +443,11 @@ formColonnade :: (Headedness h, Monoid a)
               -> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
 formColonnade = id
 
+dbColonnade :: Headedness h
+            => Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) ())
+            -> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) ())
+dbColonnade = id
+
 textCell, stringCell, i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
 stringCell = textCell
 i18nCell = textCell

templates/adminTest.hamlet

@@ -8,10 +8,10 @@
     Der Handler sollte jeweils aktuelle Beispiele für alle möglichen Funktionalitäten enthalten, so dass man immer weiß, wo man nachschlagen kann.
 
 
-<div .container>
+<div .container.js-show-hide>
   <h2 .js-show-hide__toggle>Teilweise funktionierende Abschnitte
 
-  <ul>
+  <ul .js-show-hide__target>
     <li .list-group-item>
       <a href=@{UsersR}>Benutzer Verwaltung
 

templates/default-layout.lucius

@@ -115,10 +115,6 @@ ul {
   list-style-type: none;
 }
 
-.list--inline > li {
-  display: inline-block;
-}
-
 h1, h2, h3, h4, h5 {
   font-weight: 600;
 }
@@ -214,14 +210,14 @@ h4 {
 @media (max-width: 768px) {
 
   .main__content-body {
-    padding: 0 20px 60px;
+    padding: 30px 20px 60px;
   }
 }
 
 @media (max-width: 425px) {
 
   .main__content-body {
-    padding: 0 10px 60px;
+    padding: 20px 10px 60px;
   }
 }
 
@@ -280,7 +276,6 @@ input[type="button"]:not([disabled]):hover,
 button:not([disabled]):hover,
 .btn:not([disabled]):hover {
   background-color: var(--color-light);
-  text-decoration: underline;
   color: white;
 }
 
@@ -307,10 +302,6 @@ input[type="button"].btn-info:hover,
 .table {
   margin: 21px 0;
   width: 100%;
-
-  a {
-    text-decoration: none;
-  }
 }
 
 .table--striped {
@@ -368,6 +359,10 @@ input[type="button"].btn-info:hover,
   padding-bottom: 10px;
   font-weight: bold;
   text-align: left;
+
+  a {
+    text-decoration: none;
+  }
 }
 
 @media (max-width: 1200px) {
@@ -423,6 +418,22 @@ input[type="button"].btn-info:hover,
   line-height: 25px;
 }
 
+/* LIST MODIFIERS */
+.list--inline > li {
+  display: inline-block;
+}
+
+.list--comma-separated > li {
+
+  &::after {
+    content: ', ';
+  }
+
+  &:last-of-type::after {
+    content: none;
+  }
+}
+
 /* DEFINITION LIST */
 .deflist {
   display: grid;

templates/standalone/alerts.julius

@@ -11,7 +11,6 @@
       autoDecay = parseInt(dataDecay, 10);
     }
     closeEl.classList.add('alert__close');
-    closeEl.innerText = #{String (messageRender MsgCloseAlert)};
     closeEl.addEventListener('click', function(event) {
       alertEl.classList.add('alert--invisible');
     });

templates/standalone/alerts.lucius

@@ -72,6 +72,7 @@
 
   .alert {
     margin-left: 80px;
+    max-width: 420px;
   }
 }
 

templates/standalone/showHide.julius

@@ -8,29 +8,45 @@
 
 document.addEventListener('DOMContentLoaded', function() {
 
-  var elements = Array.from(document.querySelectorAll('.js-show-hide__toggle')),
+  var LSNAME = 'SHOW_HIDE';
-      toggles = [];
 
   function addEventHandler(el) {
     el.addEventListener('click', function elClickListener() {
-      var toggle = toggles[el.dataset.index];
+      var newState = el.parentElement.classList.toggle('js-show-hide--collapsed');
-      toggle.collapsed = !toggle.collapsed;
+      updateLSState(el.dataset.shIndex || null, newState);
-      toggle.parent.classList.toggle('js-show-hide--collapsed', toggle.collapsed);
     });
   }
 
-  elements.forEach(function(el, i) {
+  function updateLSState(index, state) {
-    el.dataset.index = i;
+    if (!index) {
-    var coll = el.dataset.collapsed === 'true';
+      return false;
-    if (coll) {
-      el.parentElement.classList.add('js-show-hide--collapsed')
     }
-    Array.from(el.parentElement.children).forEach(function(el) {
+    var lsData = fromLocalStorage();
-      if (!el.classList.contains('js-show-hide__toggle')) {
+    lsData[index] = state;
-        el.classList.add('js-show-hide__target');
+    window.localStorage.setItem(LSNAME, JSON.stringify(lsData));
-      }
+  }
-    });
+
-    toggles.push({index: i, collapsed: coll, parent: el.parentElement});
+  function collapsedStateInLocalStorage(index) {
-    addEventHandler(el);
+    return fromLocalStorage()[index] || null;
+  }
+
+  function fromLocalStorage() {
+    return JSON.parse(window.localStorage.getItem(LSNAME)) || {};
+  }
+
+  Array
+    .from(document.querySelectorAll('.js-show-hide__toggle'))
+    .forEach(function(el) {
+      var index = el.dataset.shIndex || null;
+      el.parentElement.classList.toggle(
+        'js-show-hide--collapsed',
+        collapsedStateInLocalStorage(index) || el.dataset.collapsed === 'true'
+      );
+      Array.from(el.parentElement.children).forEach(function(el) {
+        if (!el.classList.contains('js-show-hide__toggle')) {
+          el.classList.add('js-show-hide__target');
+        }
+      });
+      addEventHandler(el);
   });
 });

templates/table/colonnade.hamlet

@@ -1,5 +1,5 @@
 $newline never
-<table id="#{dbtIdent}" .table.table--striped.table--hover>
+<table *{dbsAttrs'}>
   $maybe wHeaders' <- wHeaders
     <thead>
       <tr .table__row.table__row--head>
@@ -8,10 +8,10 @@ $newline never
           ^{widget}
   $nothing
   <tbody>
-    $if null wRows
+    $if null wRows && (dbsEmptyStyle == DBESHeading)
       <tr>
         <td colspan=#{show columnCount}>
-          Kein Inhalt.
+          _{dbsEmptyMessage}
     $else
       $forall row <- wRows
         <tr .table__row>

templates/table/layout.hamlet

@@ -1,10 +1,13 @@
 $newline never
-<div ##{dbtIdent}-table-wrapper>
+$if null wRows && (dbsEmptyStyle == DBESNoHeading)
-  <div .scrolltable>
+  _{dbsEmptyMessage}
-    ^{table}
+$else
-  $if pageCount > 1
+  <div ##{wIdent "table-wrapper"}>
-    <ul ##{dbtIdent}-pagination .pagination>
+    <div .scrolltable>
-      $forall p <- pageNumbers
+      ^{table}
-        <li .pagination-link :p == psPage:.current>
+    $if pageCount > 1
-          <a href=#{tblLink $ setParam (wIdent "page") (Just $ tshow p)}>
+      <ul ##{wIdent "pagination"} .pagination>
-            _{MsgPage (succ p)}
+        $forall p <- pageNumbers
+          <li .pagination-link :p == psPage:.current>
+            <a href=#{tblLink $ setParam (wIdent "page") (Just $ tshow p)}>
+              _{MsgPage (succ p)}

templates/users.hamlet

@@ -1,8 +1,2 @@
 <div .ui.container>
-
+  ^{userList}
-    <p .bg-danger>
-      This page is only for development purposes.
-
-    <h1>
-      User list
-    ^{userList}

templates/widgets/asidenav.hamlet

@@ -2,14 +2,14 @@ $newline never
 <aside .main__aside>
   <div .asidenav>
     $forall tid@TermIdentifier{..} <- favouriteTerms
-      <div .asidenav__box>
+      <div .asidenav__box.js-show-hide>
-        <h3 .asidenav__box-title.js-show-hide__toggle>
+        <h3 .asidenav__box-title.js-show-hide__toggle data-sh-index="#{display season}-#{year}">
           $case season
             $of Winter
               _{MsgWinterTermShort year}
             $of Summer
               _{MsgSummerTermShort year}
-        <ul .asidenav__list>
+        <ul .asidenav__list.js-show-hide__target>
           $forall (Course{..}, courseRoute, pageActions) <- favouriteTerm tid
             <li .asidenav__list-item :highlight courseRoute:.asidenav__list-item--active>
               <a .asidenav__link-wrapper href=@{courseRoute}>

templates/widgets/asidenav.julius

@@ -19,15 +19,21 @@
 document.addEventListener('DOMContentLoaded', function() {
 
   var asidenavEl = document.querySelector('.main__aside');
-  var mainEl = document.querySelector('.main__content');
+  var mainContentEl = document.querySelector('.main__content');
 
-  asidenavEl.style.height = `${mainEl.clientHeight + 75}px`;
+  function adjustHeight() {
-
-  window.addEventListener('resize', function() {
     window.requestAnimationFrame(function() {
-      asidenavEl.style.height = `${mainEl.clientHeight + 75}px`;
+      asidenavEl.style.height = mainContentEl.clientHeight + 'px';
     });
-  });
+  }
+
+  // unbeknownst to the user (below the fold),  this happes slightly delayed
+  // because of dynamic changes to the styles inside the main__content
+  setTimeout(function() {
+    adjustHeight();
+  }, 10);
+
+  window.addEventListener('resize', adjustHeight);
 
   window.utils.aside(asidenavEl);
 

templates/widgets/asidenav.lucius

@@ -16,6 +16,13 @@
   }
 }
 
+@media (max-width: 768px) {
+
+  .main__aside {
+    min-height: calc(100% - var(--header-height-collapsed));
+  }
+}
+
 @media (max-width: 425px) {
 
   .main__aside {