From bc094dc81381be53d6320c78bcd849a7b2fbc28f Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 4 Jan 2018 20:07:41 +0100 Subject: [PATCH] Sheets still incomplete, show sheet list and working. sheetAdmin template is not yet working --- Datenschutznotizen.txt | 27 ++++++++ models | 1 + routes | 12 ++-- src/CryptoID.hs | 3 + src/Foundation.hs | 8 +++ src/Handler/Course.hs | 13 +++- src/Handler/Sheet.hs | 120 ++++++++++++++++++++++++++++++++---- src/Handler/Users.hs | 19 +++--- src/Handler/Utils.hs | 29 +++++++-- src/Handler/Utils/Form.hs | 16 ++++- src/Model/Types.hs | 6 ++ templates/sheetAdmin.hamlet | 30 +++++++++ 12 files changed, 250 insertions(+), 34 deletions(-) create mode 100644 Datenschutznotizen.txt create mode 100644 templates/sheetAdmin.hamlet diff --git a/Datenschutznotizen.txt b/Datenschutznotizen.txt new file mode 100644 index 000000000..4ffa87b2f --- /dev/null +++ b/Datenschutznotizen.txt @@ -0,0 +1,27 @@ +* Datensparsamkeit: nur Speichern was notwendig ist; Dokumentieren, warum was gespeichert wird! +* Verfügbarkeit: Backup / aktuelles System; nicht nur eine Person, Anfragen werden organisiert beantwortet +* Integrität: Konsistenzcheck bei Datenübertragen (z.B. LDAP), Sicherheit vor bösen Absichten, Änderungen protokolliert +* Vertraulichkeit: Jeder Benutzer sollte nur auf das zugreifen was unbedingt nötig ist; Backup Verschlüsselung +* Nichtverkettbarkeit: (eher irrelevant für unseren Anwendungsfall) +* Transparenz: User weiß was über ihn gespeichert wird; Dokumentation; Vorfälle schnell melden? +* Intervenierbarkeit: Korrektur/Löschpflichten - auch im Backup; z.B. Korrekturen bei Einspielen des Backups einpflegen; Backup Verschlüsselung; Bei Löschanforderungen muss teilweise gelöscht werden (nur was Notenrelevant muss aufgehoben werden, Hausaufgaben werden gelöscht; Anzeige gelöschter Teilnehmer) +* Wer ist Datenschutzverantwortlicher? Steffen!?! + => Sofort anzeigen, wenn etwas schiefläuft. + + +Fragen: + - Was ist mit Abschreiber-Flags: Keine Flags, sondern protokollieren: bei Überschreiten einer Schwelle sollte jemand mit entsprechender Befugnis benachrichtigt werden, Student sollte die Eintragungen sehen, Assistenten nicht + + +Aktionen: + - Felder für Aufbewahrungsfristen zu jedem Datensatz + - List gelöschter Kennungen + - Zugangsberechtigungen für Vorlesungen/Übungen + - Regularien für Prozess; Aufbewahrungsfristen, Verwaltungsrechtliche Fragen, Bayrisches E-Goverment Gesetz, Daten signierbar/verifizieren; + + -> Aktuelle Archivierung von prüfungsrelevanten Daten (Klausur-Lagerung) ist nicht Gesetz-Konform; da Papier-Lagerung nicht konform ist. + + + + + diff --git a/models b/models index fa564bc26..c325b4c6b 100644 --- a/models +++ b/models @@ -104,6 +104,7 @@ Sheet changed UTCTime createdBy UserId changedBy UserId + CourseSheet courseId name SheetFile sheetId SheetId fileId FileId diff --git a/routes b/routes index c1344548d..6f85b0dfe 100644 --- a/routes +++ b/routes @@ -18,10 +18,14 @@ /course/#TermIdentifier/#Text/edit CourseEditExistR GET /course/#TermIdentifier/#Text/show CourseShowR GET POST -/course/#TermIdentifier/#Text/sheet/ SheetListR GET -/course/#TermIdentifier/#Text/sheet/new SheetNewR GET -/course/#TermIdentifier/#Text/sheet/#SheetId/show SheetShowR GET -/course/#TermIdentifier/#Text/sheet/#SheetId/edit SheetEditR GET +/course/#TermIdentifier/#Text/sheet/ SheetListR GET +/course/#CourseId/sheet/ SheetListCID GET +/course/#TermIdentifier/#Text/sheet/#Text/show SheetShowR GET +/sheet/#SheetId/show SheetIdShowR GET +/sheetuuid/#CryptoUUIDSheet/show SheetUUIDShowR GET +/course/#TermIdentifier/#Text/sheet/new SheetNewR GET +/course/#TermIdentifier/#Text/sheet/#SheetId/edit SheetEditR GET POST +/course/#TermIdentifier/#Text/sheet/#SheetId/delete SheetDelR POST /submission SubmissionListR GET POST diff --git a/src/CryptoID.hs b/src/CryptoID.hs index b8889ebac..25d19fdca 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -30,6 +30,9 @@ instance PathPiece UUID where toPathPiece = pack . toString +-- Generates CryptoUUID... Datatypes decCryptoIDs [ ''SubmissionId , ''CourseId + , ''SheetId ] +{- TODO: Do we need/want CryptoUUIDs for Sheet numbers? -} diff --git a/src/Foundation.hs b/src/Foundation.hs index 4af75fead..60ca35d2a 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -246,6 +246,14 @@ instance YesodBreadcrumbs UniWorX where breadcrumb CourseEditR = return ("Neu", Just CourseListR) breadcrumb (CourseEditExistR _ _) = return ("Editieren", Just CourseListR) + breadcrumb (SheetListR tid csh) = return ("Kurs", Just $ CourseShowR tid csh) + breadcrumb (SheetShowR tid csh _shn) = return ("Übungen", Just $ SheetListR tid csh) + breadcrumb (SheetUUIDShowR sUUID) = do + cIDKey <- getsYesod appCryptoIDKey + sheetId <- UUID.decrypt cIDKey sUUID + sheet <- runDB $ get sheetId + return ("Übungen", (SheetListCID . sheetCourseId) <$> sheet ) + breadcrumb SubmissionListR = return ("Abgaben", Just HomeR) breadcrumb (SubmissionR _) = return ("Abgabe", Just SubmissionListR) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index aaf4f97c5..db7f4d597 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -277,8 +277,16 @@ newCourseForm template = identForm FIDcourse $ \html -> do -- & addAttr "disabled" "disabled" & setTooltip "Muss innerhalb des Semesters eindeutig sein") (cfShort <$> template) +<<<<<<< HEAD <*> areq termActiveField (fsb "Semester") (cfTerm <$> template) <*> areq schoolField (fsb "Institut") (cfSchool <$> template) +||||||| merged common ancestors + <*> areq termExistsField (fsb "Semester") (cfTerm <$> template) + <*> areq (selectField schools) (fsb "Institut") (cfSchool <$> template) +======= + <*> areq termExistsField (fsb "Semester") (cfTerm <$> template) + <*> areq schoolField (fsb "Institut") (cfSchool <$> template) +>>>>>>> Sheets still incomplete, show sheet list and working. sheetAdmin template is not yet working <*> aopt (natField "Kapazität") (fsb "Kapazität") (cfCapacity <$> template) <*> areq checkBoxField (fsb "Anmeldung") (cfHasReg <$> template) <*> aopt utcTimeField (fsb "Anmeldung von:") (cfRegFrom <$> template) @@ -299,10 +307,11 @@ newCourseForm template = identForm FIDcourse $ \html -> do |] ) _ -> (result, widget) - where +-- where -- cid :: Maybe CourseId -- cid = join $ cfCourseId <$> template - + + validateCourse :: CourseForm -> [Text] validateCourse (CourseForm{..}) = [ msg | (False, msg) <- diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 63cdb036f..1255a6ceb 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -10,14 +13,14 @@ import Import import Handler.Utils -- import Data.Time --- import qualified Data.Text as T +import qualified Data.Text as T -- import Data.Function ((&)) -- import Yesod.Form.Bootstrap3 -- --- import Colonnade hiding (fromMaybe) --- import Yesod.Colonnade +import Colonnade -- hiding (fromMaybe) +import Yesod.Colonnade -- --- import qualified Data.UUID.Cryptographic as UUID +import qualified Data.UUID.Cryptographic as UUID {- @@ -26,25 +29,118 @@ import Handler.Utils * Implement Access in Foundation -} +data SheetForm = SheetForm + { sfCourseId :: CourseId + , sfName :: Text + , sfType :: SheetType + , sfMarkingText :: Maybe Text + , sfActiveFrom :: UTCTime + , sfActiveTo :: UTCTime + , sfHintFrom :: Maybe UTCTime + , sfSolutionFrom :: Maybe UTCTime + , sfSheetF :: Maybe FileInfo + , sfHintF :: Maybe FileInfo + , sfSolutionF :: Maybe FileInfo + } + +{- +makeSheetForm :: CourseId -> Maybe SheetForm -> Form SheetForm +makeSheetForm cid template = identForm FIDsheet $ \html -> do + (result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ SheetForm + <$> areq hiddenField "KursId" $ Just cid + <*> areq textField (fsb "Name") (sfName <$> template) + <*> sheetTypeAFormReq (fsb "Bewertung") (sfType <$> template) + <*> aopt textField (fsb "Hinweise zur Bewertung") (sfMarkingText <$> template) + CONTINUE HERE +-} + + +fetchSheet :: TermIdentifier -> Text -> Text -> YesodDB UniWorX (Entity Sheet) +fetchSheet tid csh shn = do + -- TODO: More efficient with Esquleto? + (Entity cid _course) <- getBy404 $ CourseTermShort (TermKey tid) csh + getBy404 $ CourseSheet cid shn + +-- List Sheets +getSheetListCID :: CourseId -> Handler Html +getSheetListCID cid = getSheetList =<< + (Entity cid) <$> (runDB $ get404 cid) getSheetListR :: TermIdentifier -> Text -> Handler Html -getSheetListR tid csh = do --- mbAid <- maybeAuthId --- _ <- runDB $ do --- courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort (TermKey tid) csh - defaultLayout [whamlet| Under Construction !!! |] -- TODO +getSheetListR tid csh = getSheetList =<< + (runDB $ getBy404 $ CourseTermShort (TermKey tid) csh) + +getSheetList :: Entity Course -> Handler Html +getSheetList courseEnt = do + -- mbAid <- maybeAuthId + let cid = entityKey courseEnt + let course = entityVal courseEnt + let csh = courseShorthand course + let tid = unTermKey $ courseTermId course + sheets <- runDB $ do + rawSheets <- selectList [SheetCourseId ==. cid] [Desc SheetActiveFrom] + forM rawSheets $ \(Entity sid sheet) -> do + let sheetsub = [SubmissionSheetId ==. sid] + submissions <- count sheetsub + rated <- count $ (SubmissionRatingTime !=. Nothing):sheetsub + return (sid, sheet, (submissions, rated)) + let colSheets = mconcat + [ headed "Blatt" $ toWgt . sheetName . snd3 + , headed "Abgabe ab" $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3 + , headed "Abgabe bis" $ toWgt . formatTimeGerWD . sheetActiveTo . snd3 + , headed "Bewertung" $ toWgt . show . sheetType . snd3 + , headed "Korrigiert" $ toWgt . snd . trd3 + , headed "Eingereicht" $ toWgt . fst . trd3 + -- TODO: only show edit button for allowed course assistants + , headed "" $ \s -> linkButton "Edit" BCLink $ SheetEditR tid csh $ fst3 s + ] + defaultLayout $ do + setTitle $ toHtml $ T.append "Übungsblätter " csh + if null sheets + then [whamlet|Es wurden noch keine Übungsblätter angelegt.|] + else encodeHeadedWidgetTable tableDefault colSheets sheets + +-- Show single sheet +getSheetShowR :: TermIdentifier -> Text -> Text -> Handler Html +getSheetShowR tid csh shn = getSheetShow =<< + (runDB $ fetchSheet tid csh shn) + +getSheetIdShowR :: SheetId -> Handler Html +getSheetIdShowR sheetId = getSheetShow =<< + (Entity sheetId) <$> (runDB $ get404 sheetId) + +getSheetUUIDShowR :: CryptoUUIDSheet -> Handler Html +getSheetUUIDShowR sUUID = do + cIDKey <- getsYesod appCryptoIDKey + sheetId <- UUID.decrypt cIDKey sUUID + sheetEnt <- runDB $ get404 sheetId + getSheetShow $ Entity sheetId sheetEnt + +getSheetShow :: (Entity Sheet) -> Handler Html +getSheetShow entSheet = do + let sheet = entityVal entSheet + defaultLayout $ do + setTitle $ toHtml $ T.append "Übung " $ sheetName sheet + -- $(widgetFile "sheetAdmin") + [whamlet| Under Construction !!! |] -- TODO + getSheetNewR :: TermIdentifier -> Text -> Handler Html -getSheetNewR _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO +getSheetNewR tid csh = do + (Entity cid course) <- runDB $ getBy404 $ CourseTermShort (TermKey tid) csh + defaultLayout [whamlet| Under Construction !!! |] -- TODO -getSheetShowR :: TermIdentifier -> Text -> SheetId -> Handler Html -getSheetShowR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO getSheetEditR :: TermIdentifier -> Text -> SheetId -> Handler Html getSheetEditR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO +postSheetEditR :: TermIdentifier -> Text -> SheetId -> Handler Html +postSheetEditR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO +postSheetDelR :: TermIdentifier -> Text -> SheetId -> Handler Html +postSheetDelR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO + {- getCourseShowR :: TermIdentifier -> Text -> Handler Html getCourseShowR tid csh = do diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 4b7fb55ad..7ac3bd00c 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -20,24 +20,25 @@ import Yesod.Colonnade getUsersR :: Handler Html getUsersR = do -- TODO: Esqueleto, combine the two queries into one - users <- runDB $ - (selectList [] [Asc UserDisplayName]) - >>= (mapM (\usr -> (,,) - <$> (pure usr) - <*> (selectList [UserAdminUser ==. (entityKey usr)] [Asc UserAdminSchool]) - <*> (selectList [UserLecturerUser ==. (entityKey usr)] [Asc UserLecturerSchool]) - )) - schools <- runDB $ selectList [] [Asc SchoolShorthand] + (users,schools) <- runDB $ (,) + <$> (selectList [] [Asc UserDisplayName] + >>= mapM (\usr -> (,,) + <$> pure usr + <*> selectList [UserAdminUser ==. entityKey usr] [Asc UserAdminSchool] + <*> selectList [UserLecturerUser ==. entityKey usr] [Asc UserLecturerSchool] + )) + <*> selectList [] [Asc SchoolShorthand] let schoolnames = entities2map schools let getSchoolname = \sid -> case lookup sid schoolnames of Nothing -> "???" (Just school) -> schoolShorthand school - let colonnadeUsers = mconcat + let colonnadeUsers = mconcat $ [ headed "User" $ text2widget.userDisplayName.entityVal.fst3 , headed "Admin for Schools" $ (\u -> text2widget $ intercalate ", " $ map (getSchoolname.userAdminSchool .entityVal) $ snd3 u) , headed "Lecturer at Schools" $ (\u -> text2widget $ intercalate ", " $ map (getSchoolname.userLecturerSchool.entityVal) $ trd3 u) ] + -- ++ map (\school -> headed (text2widget $ schoolName $ entityVal school) (\u -> "xx")) schools defaultLayout $ do setTitle "Comprehensive User List" let userList = encodeHeadedWidgetTable tableDefault colonnadeUsers users diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 10127afa0..fa6b148de 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE QuasiQuotes #-} @@ -18,7 +19,7 @@ import Handler.Utils.Zip as Handler.Utils import Handler.Utils.Rating as Handler.Utils import Handler.Utils.Submission as Handler.Utils -import Text.Blaze (Markup) +import Text.Blaze (Markup, ToMarkup) import Data.Map (Map) import qualified Data.Map as Map @@ -26,14 +27,30 @@ import qualified Data.Map as Map tickmark :: IsString a => a tickmark = fromString "✔" -withFragment :: ( Monad m - ) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ()) -withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget) +text2Html :: Text -> Html +text2Html = toHtml -- prevents ambiguous types -entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record -entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty +toWgt :: (ToMarkup a, MonadBaseControl IO m, MonadThrow m, MonadIO m) => + a -> WidgetT site m () +toWgt = toWidget . toHtml text2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => Text -> WidgetT site m () text2widget t = [whamlet|#{t}|] +str2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => + String -> WidgetT site m () +str2widget s = [whamlet|#{s}|] + + +withFragment :: ( Monad m + ) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ()) +withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget) + +---------- +-- Maps -- +---------- +entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record +entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty + + diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index fde3533b5..3fa164fbf 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -28,7 +28,7 @@ import Web.PathPieces (showToPathPiece, readFromPathPiece) -- Unique Form Identifiers to avoid accidents -- ------------------------------------------------ -data FormIdentifier = FIDcourse +data FormIdentifier = FIDcourse | FIDsheet deriving (Enum, Eq, Ord, Bounded, Read, Show) @@ -218,6 +218,7 @@ posIntField d = checkBool (>= 1) (T.append d " muss eine positive Zahl sein.") minIntField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Text -> Field m i minIntField m d = checkBool (>= m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) $ intField + --termField: see Utils.Term schoolField :: Field Handler SchoolId @@ -225,6 +226,19 @@ schoolField = selectField schools where schools = optionsPersistKey [] [Asc SchoolName] schoolName +schoolEntField :: Field Handler (Entity School) +schoolEntField = selectField schools + where + schools = optionsPersist [] [Asc SchoolName] schoolName + +sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType +sheetTypeAFormReq d Nothing = + -- TODO, offer options to choose between Normal/Bonus/Pass + (Normal . toPoints) <$> areq (natField "Punkte") d Nothing +sheetTypeAFormReq d (Just (Normal p)) = + -- TODO, offer options to choose between Normal/Bonus/Pass + (Normal . toPoints) <$> areq (natField "Punkte") d (Just $ fromPoints p) + utcTimeField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m UTCTime -- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing) utcTimeField = Field diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 38274f64f..46a5131a6 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -40,6 +40,12 @@ import Data.Typeable (Typeable) type Points = Centi +toPoints :: Integral a => a -> Points +toPoints = MkFixed . fromIntegral + +fromPoints :: Integral a => Points -> a +fromPoints = error "TODO: Types.fromPoints not yet implemented" + data SheetType = Bonus { maxPoints :: Points } | Normal { maxPoints :: Points } diff --git a/templates/sheetAdmin.hamlet b/templates/sheetAdmin.hamlet new file mode 100644 index 000000000..dd7191053 --- /dev/null +++ b/templates/sheetAdmin.hamlet @@ -0,0 +1,30 @@ +
+
+
+

+ #{sheetName sheet} +
+
+
+
+
+ + $maybe descr <- courseDescription course +

Beschreibung +

#{descr} + $maybe link <- courseLinkExternal course +

Homepage + #{link} +
+
+

Teilnehmer + #{participants} + $maybe capacity <- courseCapacity course + \ von #{capacity} +
+ ^{regWidget} + + + +
+