Homepage made almost presentable

2018-06-25 15:59:42 +02:00 · 2018-06-25 15:59:42 +02:00 · adcaef4642
commit adcaef4642
parent b8e1406a3b
11 changed files with 250 additions and 69 deletions
--- a/messages/de.msg
+++ b/messages/de.msg
@ -9,6 +9,7 @@ Term: Semester
 TermPlaceholder: W/S + vierstellige Jahreszahl
 TermEditHeading: Semester editieren/anlegen

+Course: Kurs
 CourseNewOk        tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} wurde erfolgreich erstellt.
 CourseEditOk       tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} wurde erfolgreich geändert.
 CourseNewDupShort  tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
@ -19,6 +20,7 @@ TermCourseListTitle tid@TermIdentifier: Kurse #{termToText tid}
 CourseEditHeading: Kurs editieren/anlegen
 CourseEditTitle: Kurs editieren/anlegen

+Sheet: Blatt
 SheetNewOk         tid@TermIdentifier courseShortHand@Text sheetName@Text: Neues Übungsblatt #{sheetName} wurde im Kurs #{termToText tid}-#{courseShortHand} erfolgreich erstellt.
 SheetTitle         tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand} #{sheetName}
 SheetTitleNew      tid@TermIdentifier courseShortHand@Text               : #{termToText tid}-#{courseShortHand}: Neues Übungsblatt
@ -28,6 +30,9 @@ SheetDelTitle      tid@TermIdentifier courseShortHand@Text sheetName@Text: Übun
 SheetDelText       submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{show submissionNo} Abgaben.
 SheetDelOk         tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht.

+Deadline: Abgabe
+Done: Eingereicht
+
 Unauthorized: Sie haben hierfür keine explizite Berechtigung.
 UnauthorizedAnd l@Text r@Text: #{l} UND #{r}
 UnauthorizedOr  l@Text r@Text: #{l} ODER #{r}
--- a/5
+++ b/5
@ -30,9 +30,10 @@
 /favicon.ico FaviconR GET                                     !free
 /robots.txt RobotsR GET                                       !free

-/        HomeR    GET POST                                    !free
+/        HomeR    GET                                         !free
 /profile ProfileR GET                                         !free
 /users   UsersR   GET                                         -- no tags, i.e. admins only
+/admin/test AdminTestR GET POST

 /terms                       TermShowR         GET            !free
 /terms/current               TermCurrentR      GET            !free
@ -68,4 +69,4 @@
 -- TODO above

 !/#UUID CryptoUUIDDispatchR GET                               !free -- just redirect
-!/*{CI FilePath} CryptoFileNameDispatchR GET                  !free
+!/*{CI FilePath} CryptoFileNameDispatchR GET                  !free
--- a/src/Application.hs
+++ b/src/Application.hs
@ -43,6 +43,7 @@ import Handler.Common
 import Handler.Home
 import Handler.Profile
 import Handler.Users
+import Handler.Admin
 import Handler.Term
 import Handler.Course
 import Handler.Sheet
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@ -637,6 +637,22 @@ pageActions (TermCourseListR _) =
      , menuItemAccessCallback' = return True
      }
  ]
+pageActions (HomeR) =
+  [
+--     NavbarAside $ MenuItem
+--       { menuItemLabel = "Benutzer"
+--       , menuItemIcon = Just "users"
+--       , menuItemRoute = UsersR
+--       , menuItemAccessCallback' = return True
+--       }
+--   ,
+    NavbarAside $ MenuItem
+      { menuItemLabel = "AdminDemo"
+      , menuItemIcon  = Nothing
+      , menuItemRoute = AdminTestR
+      , menuItemAccessCallback' = return True
+      }
+  ]

 pageActions _ = []

@ -659,6 +675,8 @@ pageHeading (CourseR tid csh CShowR)
    Entity _ Course{..} <- handlerToWidget . runDB . getBy404 $ CourseTermShort tid csh
    toWidget courseName
 -- TODO: add headings for more single course- and single term-pages
+pageHeading (AdminTestR)
+  = Just $ [whamlet|Internal Code Demonstration Page|]
 pageHeading _
  = Nothing

--- a/src/Handler/Admin.hs
+++ b/src/Handler/Admin.hs
@ -0,0 +1,60 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Handler.Admin where
+
+import Import
+import Handler.Utils
+
+-- import Data.Time
+-- import qualified Data.Text as T
+-- import Data.Function ((&))
+-- import Yesod.Form.Bootstrap3
+
+import Web.PathPieces (showToPathPiece, readFromPathPiece)
+
+-- import Colonnade hiding (fromMaybe)
+-- import Yesod.Colonnade
+
+-- import qualified Data.UUID.Cryptographic as UUID
+
+-- BEGIN - Buttons needed only here
+data CreateButton = CreateMath | CreateInf  -- Dummy for Example
+  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+
+instance PathPiece CreateButton where    -- for displaying the button only, not really for paths
+  toPathPiece   = showToPathPiece
+  fromPathPiece = readFromPathPiece
+
+instance Button CreateButton where
+  label CreateMath = [whamlet|Ma<i>thema</i>tik|]
+  label CreateInf  = "Informatik"
+
+  cssClass CreateMath = BCInfo
+  cssClass CreateInf  = BCPrimary
+-- END Button needed here
+
+
+getAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
+getAdminTestR = do
+  (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form CreateButton)
+  defaultLayout $ do
+    -- setTitle "UniWorkY Admin Testpage"
+    $(widgetFile "adminTest")
+
+postAdminTestR :: Handler Html
+postAdminTestR = do
+  ((btnResult,_), _) <- runFormPost $ buttonForm
+  case btnResult of
+    (FormSuccess CreateInf)  -> setMessage "Informatik-Knopf gedrückt"
+    (FormSuccess CreateMath) -> addMessage "warning" "Knopf Mathematik erkannt"
+    _other -> return ()
+  getAdminTestR
+
--- a/src/Handler/Home.hs
+++ b/src/Handler/Home.hs
@ -1,57 +1,131 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE IncoherentInstances #-} -- why is this needed? Instance for "display deadline" ought to be clear
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE PartialTypeSignatures #-}

 module Handler.Home where

 import Import
 import Handler.Utils

-- import Data.Time
+import Data.Time
 -- import qualified Data.Text as T
 -- import Yesod.Form.Bootstrap3

-import Web.PathPieces (showToPathPiece, readFromPathPiece)
+-- import Web.PathPieces (showToPathPiece, readFromPathPiece)

-- import Colonnade
-- import Yesod.Colonnade
+-- import Control.Lens
+import Colonnade hiding (fromMaybe, singleton)
+import Yesod.Colonnade
+import qualified Database.Esqueleto as E

 -- import qualified Data.UUID.Cryptographic as UUID

-- BEGIN - Buttons needed only here
-data CreateButton = CreateMath | CreateInf  -- Dummy for Example
-  deriving (Enum, Eq, Ord, Bounded, Read, Show)

-instance PathPiece CreateButton where    -- for displaying the button only, not really for paths
-  toPathPiece   = showToPathPiece
-  fromPathPiece = readFromPathPiece
+-- Some constants:
+nrSheetDeadlines :: Int64
+nrSheetDeadlines   = 10
+offSheetDeadlines :: NominalDiffTime
+offSheetDeadlines   = 15
+--nrExamDeadlines    = 10
+--offExamDeadlines    = 15
+--nrCourseDeadlines  = 10
+--offCourseDeadlines  = 15

-instance Button CreateButton where
-  label CreateMath = [whamlet|Ma<i>thema</i>tik|]
-  label CreateInf  = "Informatik"

-  cssClass CreateMath = BCInfo
-  cssClass CreateInf  = BCPrimary
-- END Button needed here

 getHomeR :: Handler Html
 getHomeR = do
-  (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form CreateButton)
+  muid <- maybeAuthId
+  -- let uid = fromMaybe (Key 1) muid -- TODO: delete me
+  cTime <- liftIO getCurrentTime
+  let fTime = addUTCTime (offSheetDeadlines * nominalDay) cTime
+
+      tableData :: (Maybe (Key User))
+                  -> E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant))
+                                            (E.SqlExpr (Entity Course           )))
+                                            (E.SqlExpr (Entity Sheet            ))
+                  -> E.SqlQuery ( E.SqlExpr (E.Value (Key Term))
+                                , E.SqlExpr (E.Value Text)
+                                , E.SqlExpr (E.Value Text)
+                                , E.SqlExpr (E.Value UTCTime))
+
+--       tableData Nothing    (                          course `E.InnerJoin` sheet) = do
+--         E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
+--         E.where_ $ sheet E.^. SheetActiveTo E.<=. E.val fTime
+--              E.&&. sheet E.^. SheetActiveTo E.>=. E.val cTime
+--         E.limit nrSheetDeadlines
+--         E.orderBy [ E.asc  $ sheet  E.^. SheetActiveTo
+--                   , E.desc $ sheet  E.^. SheetName
+--                   , E.desc $ course E.^. CourseShorthand
+--                   ]
+--         E.limit nrSheetDeadlines
+--         return
+--           ( course  E.^. CourseTerm
+--           , course  E.^. CourseShorthand
+--           , sheet   E.^. SheetName
+--           , sheet   E.^. SheetActiveTo
+--           )
+
+      tableData (Just uid) (participant `E.InnerJoin` course `E.InnerJoin` sheet) = do
+        E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
+        E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
+        E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
+             E.&&. sheet E.^. SheetActiveTo E.<=. E.val fTime
+             E.&&. sheet E.^. SheetActiveTo E.>=. E.val cTime
+        E.orderBy [ E.asc  $ sheet  E.^. SheetActiveTo
+                  , E.desc $ sheet  E.^. SheetName
+                  , E.desc $ course E.^. CourseShorthand
+                  ]
+        E.limit nrSheetDeadlines
+        return
+          ( course  E.^. CourseTerm
+          , course  E.^. CourseShorthand
+          , sheet   E.^. SheetName
+          , sheet   E.^. SheetActiveTo
+          )
+
+      colonnade :: Colonnade Sortable (DBRow (E.Value (Key Term), E.Value Text, E.Value Text, E.Value UTCTime)) (Cell UniWorX)
+      colonnade = mconcat
+        [ -- dbRow
+          sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, _, _) } ->
+            cell [whamlet|<a href=@{CourseR tid csh CShowR}>#{display csh}|]
+        , sortable (Just "sheet") (i18nCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _) } ->
+            cell [whamlet|<a href=@{CSheetR tid csh shn SShowR}>#{display shn}|]
+        , sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, E.Value deadline) } ->
+            textCell $ display deadline
+        , sortable (Just "done") (i18nCell MsgDone) $ \DBRow{ dbrOutput=(_, _, _, _) } ->
+            textCell $ "?"
+        ]
+  sheetTable <- dbTable def $ DBTable
+    { dbtSQLQuery  = tableData muid
+    , dbtColonnade = colonnade
+    , dbtSorting   =  [ ( "term"
+                        , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ ) -> course E.^. CourseTerm
+                        )
+                      , ( "course"
+                        , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ ) -> course E.^. CourseShorthand
+                        )
+                        -- TODO
+                      ]
+    , dbtFilter    =  mempty {- [ ( "term"
+                        , FilterColumn $ \(course `E.InnerJoin` _ `E.InnerJoin` _ ) tids -> if
+                            | Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool)
+                            | otherwise     -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
+                        )
+                        ] -}
+    , dbtAttrs     = tableDefault
+    , dbtIdent     = "upcomingdeadlines" :: Text
+    }
+
+
  defaultLayout $ do
    setTitle "Willkommen zum Uniworky Test!"
    $(widgetFile "home")
-
-
-postHomeR :: Handler Html
-postHomeR = do
-  ((btnResult,_), _) <- runFormPost $ buttonForm
-  case btnResult of
-    (FormSuccess CreateInf)  -> setMessage "Informatik-Knopf gedrückt"
-    (FormSuccess CreateMath) -> addMessage "warning" "Knopf Mathematik erkannt"
-    _other -> return ()
-  getHomeR
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@ -14,7 +14,7 @@
 module Handler.Utils.Form where

 import Handler.Utils.Form.Types
-
+import Handler.Utils.Templates

 import Handler.Utils.DateTime

--- a/src/Handler/Utils/Table.hs
+++ b/src/Handler/Utils/Table.hs
@ -35,6 +35,9 @@ numberColonnade = headed "Nr" (fromString.show)
 pairColonnade :: (Functor h) =>  Colonnade h a c -> Colonnade h b c ->  Colonnade h (a,b) c
 pairColonnade a b = mconcat [ lmap fst a, lmap snd b]

+i18nCell :: RenderMessage site a => a -> Cell site
+i18nCell msg = cell [whamlet|_{msg}|]
+

 -- Table Modification
 encodeHeadedWidgetTableNumbered :: Attribute -> Colonnade Headed a (WidgetT site IO ()) -> [a] -> WidgetT site IO ()
--- a/templates/adminTest.hamlet
+++ b/templates/adminTest.hamlet
@ -0,0 +1,44 @@
+<div .container>
+  <h1>Uniworky - Admin Demopage
+
+  <p>
+    Diese interne Seite dient lediglich zum Testen diverser Funktionalitäten
+    und zur Demonstration der verschiedenen Hilfsfunktionen/Module.
+
+    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>
+  <h2 .js-show-hide__toggle>Teilweise funktionierende Abschnitte
+
+  <ul>
+    <li .list-group-item>
+      <a href=@{UsersR}>Benutzer Verwaltung
+
+    <li .list-group-item>
+      <a href=@{TermShowR}>Semester Verwaltung
+      <a href=@{TermEditR}>Neues Semester anlegen
+
+    <li .list-group-item>
+                        <a href=@{CourseNewR}>Kurse anlegen
+
+    <li .list-group-item>
+      <a href=@{SubmissionListR}>Dateien hochladen und abrufen
+
+<hr>
+<div .container>
+  <h2>Funktionen zum Testen
+
+  <ul>
+    <li>
+      Knopf-Test:
+        <form .form-inline method=post action=@{AdminTestR} enctype=#{btnEnctype}>
+          ^{btnWdgt}
+    <li><br>
+      Modals:
+      ^{modal ".toggler1" Nothing}
+      <a href="/" .btn.toggler1>Klick mich für Ajax-Test
+        <noscript>(Für Modals bitte JS aktivieren)</noscript>
+      ^{modal ".toggler2" (Just "Test Inhalt für Modal")}
+      <div .btn.toggler2>Klick mich für Content-Test
+        <noscript>(Für Modals bitte JS aktivieren)</noscript>
--- a/templates/home.hamlet
+++ b/templates/home.hamlet
@ -1,46 +1,21 @@
 <div .container>
-  <h1>Uniworky - Demo
  <h3>
-    Testumgebung für die Re-Implementierung von <a href="https://uniworx.ifi.lmu.de/">UniWorX</a>
-  <p>
-    Die Reimplementierung von
-    UniWorX ist noch nicht abgeschlossen.
+    Re-Implementierung von <a href="https://uniworx.ifi.lmu.de/">UniWorX</a>

  <div .alert .alert-danger>
-    <div .alert__content>Das System ist noch nicht produktiv einsetzbar
+    <div .alert__content>
+      Vorabversion!
+      Die Implementierung von
+      UniWorkY ist noch nicht abgeschlossen.

-<hr>
-<div .container>
-  <h2 .js-show-hide__toggle>Teilweise funktionierende Abschnitte
+  <h1>Anstehende Übungsblätter
+    <div .container>
+      $maybe _ <- muid
+        ^{sheetTable}

-  <ul>
-    <li .list-group-item>
-      <a href=@{UsersR}>Benutzer Verwaltung
+  <h1>Anstehende Klausuren
+    TODO

-    <li .list-group-item>
-      <a href=@{TermShowR}>Semester Verwaltung
-      <a href=@{TermEditR}>Neues Semester anlegen
+  <h1>Anstehende Kursanmeldungen
+    TODO

-    <li .list-group-item>
-                        <a href=@{CourseNewR}>Kurse anlegen
-
-    <li .list-group-item>
-      <a href=@{SubmissionListR}>Dateien hochladen und abrufen
-
-<hr>
-<div .container>
-  <h2>Funktionen zum Testen
-
-  <ul>
-    <li>
-      Knopf-Test:
-        <form .form-inline method=post action=@{HomeR} enctype=#{btnEnctype}>
-          ^{btnWdgt}
-    <li><br>
-      Modals:
-      ^{modal ".toggler1" Nothing}
-      <a href="/" .btn.toggler1>Klick mich für Ajax-Test
-        <noscript>(Für Modals bitte JS aktivieren)</noscript>
-      ^{modal ".toggler2" (Just "Test Inhalt für Modal")}
-      <div .btn.toggler2>Klick mich für Content-Test
-        <noscript>(Für Modals bitte JS aktivieren)</noscript>
--- a/templates/multiFileField.hamlet
+++ b/templates/multiFileField.hamlet
@ -18,4 +18,4 @@ $# new files
  <span .unpack-zip-info-toggler>?

 $# TODO: make modal available in this scope
-$# ^{modal ".unpack-zip-info-toggler" (Just "Entpackt zips automatisch nach dem Upload und fügt den Inhalt im Stamm-Verzeichnis ein.")}
+    ^{modal ".unpack-zip-info-toggler" (Just "Entpackt zips automatisch nach dem Upload und fügt den Inhalt im Stamm-Verzeichnis ein.")}