diff --git a/messages/de.msg b/messages/de.msg index 812f45c9a..618a03950 100644 --- 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} diff --git a/routes b/routes index 7dd978fd6..140ccde30 100644 --- a/routes +++ b/routes @@ -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 \ No newline at end of file +!/*{CI FilePath} CryptoFileNameDispatchR GET !free diff --git a/src/Application.hs b/src/Application.hs index 33a3fd07b..a671b5296 100644 --- 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 diff --git a/src/Foundation.hs b/src/Foundation.hs index ca962f9d1..0f6021eee 100644 --- 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 diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs new file mode 100644 index 000000000..cafd75dbe --- /dev/null +++ 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|Mathematik|] + 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 + diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 9a08c934b..d5c794037 100644 --- 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|Mathematik|] - 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|#{display csh}|] + , sortable (Just "sheet") (i18nCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _) } -> + cell [whamlet|#{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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 9d5684a50..eee978301 100644 --- 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 diff --git a/src/Handler/Utils/Table.hs b/src/Handler/Utils/Table.hs index b85ab899b..bb1f621fd 100644 --- 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 () diff --git a/templates/adminTest.hamlet b/templates/adminTest.hamlet new file mode 100644 index 000000000..f3a48a134 --- /dev/null +++ b/templates/adminTest.hamlet @@ -0,0 +1,44 @@ +
+

Uniworky - Admin Demopage + +

+ 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. + + +

+

Teilweise funktionierende Abschnitte + +