Sheets still incomplete, show sheet list and working. sheetAdmin template is not yet working

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

models

@@ -104,6 +104,7 @@ Sheet
     changed         UTCTime
     createdBy       UserId
     changedBy       UserId    
+    CourseSheet courseId name
 SheetFile
     sheetId         SheetId
     fileId          FileId

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/                SheetListR  GET
-/course/#TermIdentifier/#Text/sheet/new           SheetNewR   GET
+/course/#CourseId/sheet/                            SheetListCID GET
-/course/#TermIdentifier/#Text/sheet/#SheetId/show SheetShowR  GET
+/course/#TermIdentifier/#Text/sheet/#Text/show      SheetShowR  GET
-/course/#TermIdentifier/#Text/sheet/#SheetId/edit SheetEditR  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

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? -}

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)
   

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) <-

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 Colonnade  -- hiding (fromMaybe)
--- import Yesod.Colonnade 
+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
+getSheetListR tid csh = getSheetList =<<
---   mbAid <- maybeAuthId
+  (runDB $ getBy404 $ CourseTermShort (TermKey tid) csh)
---   _ <- runDB $ do
+
---         courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort (TermKey tid) csh
+getSheetList :: Entity Course -> Handler Html
-  defaultLayout [whamlet| Under Construction !!! |] -- TODO
+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

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 $
+  (users,schools) <- runDB $ (,)
-    (selectList [] [Asc UserDisplayName])
+    <$> (selectList [] [Asc UserDisplayName]
-    >>= (mapM (\usr -> (,,)
+        >>= mapM (\usr -> (,,)
-      <$> (pure usr)
+          <$> pure usr
-      <*> (selectList [UserAdminUser    ==. (entityKey usr)] [Asc UserAdminSchool])
+          <*> selectList [UserAdminUser    ==. entityKey usr] [Asc UserAdminSchool]
-      <*> (selectList [UserLecturerUser ==. (entityKey usr)] [Asc UserLecturerSchool])
+          <*> selectList [UserLecturerUser ==. entityKey usr] [Asc UserLecturerSchool]
-    ))
+        ))
-  schools <- runDB $ selectList [] [Asc SchoolShorthand]
+    <*> 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

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
+text2Html :: Text -> Html
-                ) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ())
+text2Html = toHtml -- prevents ambiguous types
-withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget)
 
-entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record
+toWgt :: (ToMarkup a, MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
-entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty
+  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
+
+

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 

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 }

templates/sheetAdmin.hamlet

@@ -0,0 +1,30 @@
+<div .masthead>
+    <div .container>
+        <div .row>
+            <h1 .header>
+              #{sheetName sheet}
+<div .container>
+    <div .bs-docs-section>
+        <div .row>
+            <div .col-lg-12>
+                <div .page-header>                    
+
+                    $maybe descr <- courseDescription course
+                      <h2 #description>Beschreibung
+                      <p> #{descr}  
+                    $maybe link <- courseLinkExternal course
+                      <h4 #linl>Homepage
+                      <a href=#{link}>#{link}
+        <div .row>
+            <div .col-lg-12>     
+                <h4>Teilnehmer
+                #{participants}
+                $maybe capacity <- courseCapacity course
+                  \ von #{capacity}
+                <form method=post action=@{CourseShowR tid csh} enctype=#{regEnctype}>
+                  ^{regWidget}
+                
+
+
+    <hr>
+