diff --git a/.gitignore b/.gitignore index 932688139..6338c36b4 100644 --- a/.gitignore +++ b/.gitignore @@ -18,7 +18,8 @@ cabal.sandbox.config *.swp *.keter *~ -\#* +**/\#* +**/.\#* uniworx.cabal uniworx.nix .gup/ @@ -26,4 +27,4 @@ uniworx.nix *.kate-swp src/Handler/Assist.bak src/Handler/Course.SnapCustom.hs - +*.orig 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/fill-db.hs b/fill-db.hs new file mode 100755 index 000000000..41631aebb --- /dev/null +++ b/fill-db.hs @@ -0,0 +1,71 @@ +#!/usr/bin/env stack +-- stack runghc + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE NoImplicitPrelude #-} + +import "uniworx" Import +import "uniworx" Application (db) + +import Data.Time + +main :: IO () +main = db $ do + now <- liftIO getCurrentTime + let + winter2017 = TermIdentifier 2017 Winter + summer2018 = TermIdentifier 2018 Summer + gkleen <- insert User + { userPlugin = "LDAP" + , userIdent = "G.Kleen@campus.lmu.de" + , userMatrikelnummer = Nothing + , userEmail = "G.Kleen@campus.lmu.de" + , userDisplayName = "Gregor Kleen" + } + void . insert $ Term + { termName = winter2017 + , termStart = fromGregorian 2017 10 16 + , termEnd = fromGregorian 2018 02 10 + , termHolidays = [fromGregorian 2017 12 24..fromGregorian 2018 01 06] + , termLectureStart = fromGregorian 2017 10 16 + , termLectureEnd = fromGregorian 2018 02 10 + , termActive = True + } + void . insert $ Term + { termName = summer2018 + , termStart = fromGregorian 2018 04 09 + , termEnd = fromGregorian 2018 07 14 + , termHolidays = [] + , termLectureStart = fromGregorian 2018 04 09 + , termLectureEnd = fromGregorian 2018 07 14 + , termActive = True + } + ifi <- insert $ School "Institut für Informatik" "IfI" + mi <- insert $ School "Institut für Mathematik" "MI" + void . insert $ UserAdmin gkleen ifi + void . insert $ UserAdmin gkleen mi + void . insert $ UserLecturer gkleen ifi + ifiBsc <- insert $ Degree "Bachelor Informatik" ifi + ifiMsc <- insert $ Degree "Master Informatik" ifi + ffp <- insert Course + { courseName = "Fortgeschrittene Funktionale Programmierung" + , courseDescription = Nothing + , courseLinkExternal = Nothing + , courseShorthand = "ffp" + , courseTermId = TermKey summer2018 + , courseSchoolId = ifi + , courseCapacity = Just 20 + , courseCreated = now + , courseChanged = now + , courseCreatedBy = gkleen + , courseChangedBy = gkleen + , courseHasRegistration = True + , courseRegisterFrom = Just now + , courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now ) + } + void . insert $ DegreeCourse ifiBsc ffp + void . insert $ DegreeCourse ifiMsc ffp + void . insert $ Lecturer gkleen ffp + void . insert $ Corrector gkleen ffp (ByProportion 1) + void . insert $ Sheet ffp "Blatt 1" Nothing NotGraded Nothing now now Nothing Nothing now now gkleen gkleen diff --git a/ghci.sh b/ghci.sh new file mode 100755 index 000000000..64adc58eb --- /dev/null +++ b/ghci.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +unset HOST +export DETAILED_LOGGING=true +export LOG_ALL=true +export DUMMY_LOGIN=true + +exec -- stack ghci --flag uniworx:dev --flag uniworx:library-only diff --git a/models b/models index 8ec481079..b910cb843 100644 --- a/models +++ b/models @@ -37,8 +37,8 @@ Term json lectureStart Day lectureEnd Day active Bool - Primary name - deriving Show + Primary name -- newtype Key Term = TermKey { unTermKey :: TermIdentifier } + deriving Show -- type TermId = Key Term School json name Text shorthand Text @@ -94,8 +94,9 @@ CourseParticipant Sheet courseId CourseId name Text + description Html Maybe type SheetType - markingText Text Maybe + markingText Html Maybe activeFrom UTCTime activeTo UTCTime hintFrom UTCTime Maybe @@ -104,6 +105,7 @@ Sheet changed UTCTime createdBy UserId changedBy UserId + CourseSheet courseId name SheetFile sheetId SheetId fileId FileId @@ -200,6 +202,6 @@ Exam ExamUser userId UserId examId ExamId - -- CONTINUE HERE: Inlcude rating in this table or seperatly? + -- CONTINUE HERE: Include rating in this table or separately? UniqueExamUser userId examId -- By default this file is used in Model.hs (which is imported by Foundation.hs) diff --git a/package.yaml b/package.yaml index 9d3b509b1..fb495c5a8 100644 --- a/package.yaml +++ b/package.yaml @@ -10,6 +10,7 @@ dependencies: # version 1.0 had a bug in reexporting Handler, causing trouble - classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1 +- foreign-store - yesod >=1.4.3 && <1.5 - yesod-core >=1.4.30 && <1.5 - yesod-auth >=1.4.0 && <1.5 @@ -64,6 +65,7 @@ dependencies: - filepath-crypto - cryptoids-types - cryptoids +- cryptoids-class - binary - mtl - sandi @@ -75,6 +77,8 @@ dependencies: - yesod-auth-ldap - LDAP - parsec +- uuid +- exceptions # The library contains all of our application code. The executable # defined below is just a thin wrapper. @@ -87,7 +91,6 @@ library: - -Wall - -fwarn-tabs - -O0 - - -ddump-splices cpp-options: -DDEVELOPMENT else: ghc-options: diff --git a/routes b/routes index 4085fd935..8c074546b 100644 --- a/routes +++ b/routes @@ -6,22 +6,24 @@ / HomeR GET POST /profile ProfileR GET +/users UsersR GET /term TermShowR GET /term/edit TermEditR GET POST -/term/#TermIdentifier/edit TermEditExistR GET +/term/#TermId/edit TermEditExistR GET /course/ CourseListR GET !/course/new CourseEditR GET POST -!/course/#TermIdentifier CourseListTermR GET -/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/#TermId CourseListTermR GET +/course/#TermId/#Text/edit CourseEditExistR GET +/course/#TermId/#Text/show CourseShowR GET POST +/course/#TermId/#Text/sheet/ SheetListR GET +/course/#TermId/#Text/sheet/#Text/show SheetShowR GET +/course/#TermId/#Text/sheet/#Text/#SheetFileType/#FilePath SheetFileR GET +/course/#TermId/#Text/sheet/new SheetNewR GET POST +/course/#TermId/#Text/sheet/#SheetId/edit SheetEditR GET POST +/course/#TermId/#Text/sheet/#SheetId/delete SheetDelR GET POST /submission SubmissionListR GET POST /submission/#CryptoUUIDSubmission SubmissionR GET POST @@ -29,5 +31,7 @@ !/submission/archive/#FilePath SubmissionDownloadArchiveR GET !/submission/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET +!/#UUID CryptoUUIDDispatchR GET + -- For demonstration /course/#CryptoUUIDCourse/edit CourseEditExistIDR GET diff --git a/shell.nix b/shell.nix index df2997a61..1274430f9 100644 --- a/shell.nix +++ b/shell.nix @@ -1,4 +1,4 @@ -{ nixpkgs ? import {}, compiler ? null }: +{ nixpkgs ? import {}, compiler ? "ghc822" }: let inherit (nixpkgs) pkgs; @@ -22,7 +22,7 @@ let ''; override = oldAttrs: { - nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql ]) ++ (with haskellPackages; [ stack stack-run yesod-bin ]); + nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql cabal-install ]) ++ (with haskellPackages; [ stack yesod-bin ]); shellHook = '' ${oldAttrs.shellHook} export PROMPT_INFO="${oldAttrs.name}" @@ -36,13 +36,18 @@ let psql -f ${postgresSchema} postgres printf "Postgres logfile is %s\nPostgres socket directory is %s\n" ''${pgLogFile} ''${pgSockDir} - env --unset=shellHook zsh - ret=$? + cleanup() { + pg_ctl stop -D ''${pgDir} + rm -rvf ''${pgDir} ''${pgSockDir} ''${pgLogFile} + } - pg_ctl stop -D ''${pgDir} - rm -rvf ''${pgDir} ''${pgSockDir} ''${pgLogFile} - exit ''${ret} + trap cleanup EXIT ''; }; -in - pkgs.stdenv.lib.overrideDerivation drv.env override + + dummy = pkgs.stdenv.mkDerivation { + name = "interactive-uniworx-environment"; + shellHook = ""; + }; +in pkgs.stdenv.lib.overrideDerivation dummy override + #pkgs.stdenv.lib.overrideDerivation drv.env override diff --git a/src/Application.hs b/src/Application.hs index 403bf072c..33a3fd07b 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -42,10 +42,12 @@ import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, import Handler.Common import Handler.Home import Handler.Profile +import Handler.Users import Handler.Term import Handler.Course import Handler.Sheet import Handler.Submission +import Handler.CryptoIDDispatch -- This line actually creates our YesodDispatch instance. It is the second half diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 9eecc80a0..25d19fdca 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -7,8 +7,9 @@ module CryptoID ( module CryptoID - , module Data.UUID.Cryptographic - , module Data.CryptoID.Poly + , module Data.CryptoID.Poly.ImplicitNamespace + , module Data.UUID.Cryptographic.ImplicitNamespace + , module System.FilePath.Cryptographic.ImplicitNamespace ) where import CryptoID.TH @@ -16,10 +17,10 @@ import CryptoID.TH import ClassyPrelude hiding (fromString) import Model -import Data.CryptoID -import Data.CryptoID.Poly hiding (encrypt, decrypt) +import Data.CryptoID.Poly.ImplicitNamespace +import Data.UUID.Cryptographic.ImplicitNamespace +import System.FilePath.Cryptographic.ImplicitNamespace -import Data.UUID.Cryptographic import Data.UUID.Types import Web.PathPieces @@ -28,10 +29,10 @@ instance PathPiece UUID where fromPathPiece = fromString . unpack toPathPiece = pack . toString -decKeysBinary [ ''SubmissionId - , ''CourseId - ] -decTypeAliases [ "Submission" - , "Course" - ] +-- Generates CryptoUUID... Datatypes +decCryptoIDs [ ''SubmissionId + , ''CourseId + , ''SheetId + ] +{- TODO: Do we need/want CryptoUUIDs for Sheet numbers? -} diff --git a/src/CryptoID/TH.hs b/src/CryptoID/TH.hs index 20073bb85..23122dadf 100644 --- a/src/CryptoID/TH.hs +++ b/src/CryptoID/TH.hs @@ -8,7 +8,7 @@ import ClassyPrelude import Language.Haskell.TH -import Data.CryptoID (CryptoID) +import Data.CryptoID.Class.ImplicitNamespace import Data.UUID.Types (UUID) import Data.Binary (Binary(..)) import Data.Binary.SerializationLength @@ -19,28 +19,30 @@ import System.FilePath (FilePath) import Database.Persist.Sql (toSqlKey, fromSqlKey) -decTypeAliases :: [String] -> Q [Dec] -decTypeAliases = return . concatMap decTypeAliases' +decCryptoIDs :: [Name] -> DecsQ +decCryptoIDs = fmap concat . mapM decCryptoID where - decTypeAliases' :: String -> [Dec] - decTypeAliases' n - = [ TySynD cryptoIDn [] $ ConT ''CryptoID `AppT` LitT (StrTyLit n) - , TySynD cryptoUUIDn [] $ ConT cryptoIDn `AppT` ConT ''UUID - , TySynD cryptoBase32n [] $ ConT cryptoIDn `AppT` (ConT ''CI `AppT` ConT ''FilePath) + decCryptoID :: Name -> DecsQ + decCryptoID n@(conT -> t) = do + instances <- [d| + instance Binary $(t) where + get = $(varE 'toSqlKey) <$> get + put = put . $(varE 'fromSqlKey) + instance HasFixedSerializationLength $(t) where + type SerializationLength $(t) = SerializationLength Int64 + + type instance CryptoIDNamespace a $(t) = $(litT $ strTyLit ns) + |] + + synonyms <- mapM cryptoIDSyn + [ (ConT ''UUID, "UUID") + , (ConT ''CI `AppT` ConT ''FilePath, "FileName") + ] + + return $ concat + [ instances + , synonyms ] where - cryptoIDn = mkName $ "CryptoID" ++ n - cryptoUUIDn = mkName $ "CryptoUUID" ++ n - cryptoBase32n = mkName $ "CryptoFileName" ++ n - -decKeysBinary :: [Name] -> DecsQ -decKeysBinary = fmap concat . mapM decKeyBinary - where - decKeyBinary :: Name -> DecsQ - decKeyBinary (conT -> t) - = [d| instance Binary $(t) where - get = $(varE 'toSqlKey) <$> get - put = put . $(varE 'fromSqlKey) - instance HasFixedSerializationLength $(t) where - type SerializationLength $(t) = SerializationLength Int64 - |] + ns = (\nb -> fromMaybe nb $ stripSuffix "Id" nb) $ nameBase n + cryptoIDSyn (ct, str) = tySynD (mkName $ "Crypto" ++ str ++ ns) [] $ conT ''CryptoID `appT` return ct `appT` t diff --git a/src/Foundation.hs b/src/Foundation.hs index d1e55c9a3..7b86343d7 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -8,6 +8,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} module Foundation where @@ -48,8 +49,6 @@ import Data.Conduit.List (sourceList) import Control.Monad.Except (MonadError(..), runExceptT) import Handler.Utils.StudyFeatures -import qualified Data.UUID.Cryptographic as UUID -import qualified System.FilePath.Cryptographic as FilePath import System.FilePath import Handler.Utils.Templates @@ -78,7 +77,7 @@ data UniWorX = UniWorX -- -- This function also generates the following type synonyms: -- type Handler = HandlerT UniWorX IO --- type Widget = WidgetT UniWorX IO () +-- type Widget = WidgetT UniWorX IO () mkYesodData "UniWorX" $(parseRoutesFile "routes") data MenuItem = MenuItem @@ -135,6 +134,7 @@ instance Yesod UniWorX where isAuthorized CourseListR _ = return Authorized isAuthorized (CourseListTermR _) _ = return Authorized isAuthorized (CourseShowR _ _) _ = return Authorized + isAuthorized (CryptoUUIDDispatchR _) _ = return Authorized isAuthorized SubmissionListR _ = isAuthenticated isAuthorized SubmissionDownloadMultiArchiveR _ = isAuthenticated -- isAuthorized TestR _ = return Authorized @@ -180,24 +180,24 @@ instance Yesod UniWorX where makeLogger = return . appLogger isAuthorizedDB :: Route UniWorX -> Bool -> YesodDB UniWorX AuthResult +isAuthorizedDB UsersR _ = adminAccess Nothing isAuthorizedDB (SubmissionR cID) _ = submissionAccess $ Right cID isAuthorizedDB (SubmissionDownloadSingleR cID _) _ = submissionAccess $ Right cID isAuthorizedDB (SubmissionDownloadArchiveR (splitExtension -> (baseName, _))) _ = submissionAccess . Left . CryptoID $ CI.mk baseName isAuthorizedDB TermEditR _ = adminAccess Nothing isAuthorizedDB (TermEditExistR _) _ = adminAccess Nothing isAuthorizedDB CourseEditR _ = lecturerAccess Nothing -isAuthorizedDB (CourseEditExistR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort (TermKey t) c) +isAuthorizedDB (CourseEditExistR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) +isAuthorizedDB (SheetNewR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) isAuthorizedDB (CourseEditExistIDR cID) _ = do - cIDKey <- getsYesod appCryptoIDKey - courseId <- UUID.decrypt cIDKey cID + courseId <- decrypt cID courseLecturerAccess courseId -isAuthorizedDB route isWrite = return $ Unauthorized "No access to this route." -- Calling isAuthorized here creates infinite loop! +isAuthorizedDB _route _isWrite = return $ Unauthorized "No access to this route." -- Calling isAuthorized here creates infinite loop! submissionAccess :: Either CryptoFileNameSubmission CryptoUUIDSubmission -> YesodDB UniWorX AuthResult submissionAccess cID = do authId <- lift requireAuthId - cIDKey <- getsYesod appCryptoIDKey - submissionId <- either (FilePath.decrypt cIDKey) (UUID.decrypt cIDKey) cID + submissionId <- either decrypt decrypt cID Submission{..} <- get404 submissionId submissionUsers <- map (submissionUserUserId . entityVal) <$> selectList [SubmissionUserSubmissionId ==. submissionId] [] let auth = authId `elem` submissionUsers || Just authId == submissionRatingBy @@ -244,11 +244,14 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (TermEditExistR _) = return ("Editieren", Just TermShowR) breadcrumb CourseListR = return ("Kurs", Just HomeR) - breadcrumb (CourseListTermR term) = return (termToText term, Just TermShowR) + breadcrumb (CourseListTermR term) = return (toPathPiece term, Just TermShowR) breadcrumb (CourseShowR term course) = return (course, Just $ CourseListTermR term) 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 SubmissionListR = return ("Abgaben", Just HomeR) breadcrumb (SubmissionR _) = return ("Abgabe", Just SubmissionListR) @@ -270,6 +273,11 @@ defaultLinks = -- Define the menu items of the header. , menuItemRoute = CourseListR , menuItemAccessCallback = return True } + , NavbarRight $ MenuItem + { menuItemLabel = "Users" + , menuItemRoute = UsersR + , menuItemAccessCallback = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False + } , NavbarRight $ MenuItem { menuItemLabel = "Profile" , menuItemRoute = ProfileR @@ -393,7 +401,7 @@ instance YesodAuth UniWorX where authHttpManager = getHttpManager ldapConfig :: UniWorX -> LDAPConfig -ldapConfig app@(appSettings -> settings) = LDAPConfig +ldapConfig _app@(appSettings -> settings) = LDAPConfig { usernameFilter = \u -> principalName <> "=" <> u , identifierModifier , ldapUri = appLDAPURI settings @@ -434,6 +442,11 @@ instance HasHttpManager UniWorX where unsafeHandler :: UniWorX -> Handler a -> IO a unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger + +instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where + type MonadCryptoKey m = CryptoIDKey + cryptoIDKey f = getsYesod appCryptoIDKey >>= f + -- Note: Some functionality previously present in the scaffolding has been -- moved to documentation in the Wiki. Following are some hopefully helpful -- links: diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 56190ce78..9e7b109a8 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -26,20 +26,20 @@ import qualified Data.UUID.Cryptographic as UUID getCourseListR :: Handler TypedContent getCourseListR = redirect TermShowR -getCourseListTermR :: TermIdentifier -> Handler Html +getCourseListTermR :: TermId -> Handler Html getCourseListTermR tidini = do (term,courses) <- runDB $ (,) - <$> get (TermKey tidini) - <*> selectList [CourseTermId ==. TermKey tidini] [Asc CourseShorthand] + <$> get tidini + <*> selectList [CourseTermId ==. tidini] [Asc CourseShorthand] when (isNothing term) $ do - addMessage "warning" [shamlet| Semester #{termToText tidini} nicht gefunden. |] + addMessage "warning" [shamlet| Semester #{toPathPiece tidini} nicht gefunden. |] redirect TermShowR -- TODO: several runDBs per TableRow are probably too inefficient! let colonnadeTerms = mconcat [ headed "Kürzel" $ (\ckv -> let c = entityVal ckv shd = courseShorthand c - tid = unTermKey $ courseTermId c + tid = courseTermId c in [whamlet| #{shd} |] ) -- , headed "Institut" $ [shamlet| #{course} |] , headed "Beginn Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterFrom.entityVal @@ -52,7 +52,7 @@ getCourseListTermR tidini = do , headed " " $ (\ckv -> let c = entityVal ckv shd = courseShorthand c - tid = unTermKey $ courseTermId c + tid = courseTermId c in do adminLink <- handlerToWidget $ isAuthorized (CourseEditExistR tid shd ) False -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditExistR tid shd) else "" @@ -74,13 +74,13 @@ getCourseListTermR tidini = do -- defaultLayout $ do setTitle "Semesterkurse" linkButton "Neuen Kurs anlegen" BCPrimary CourseEditR - encodeHeadedWidgetTable tableDefault colonnadeTerms courses -- (map entityVal courses) + encodeWidgetTable tableDefault colonnadeTerms courses -- (map entityVal courses) -getCourseShowR :: TermIdentifier -> Text -> Handler Html +getCourseShowR :: TermId -> Text -> Handler Html getCourseShowR tid csh = do mbAid <- maybeAuthId (courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do - courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort (TermKey tid) csh + courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort tid csh dependent <- (,,) <$> get (courseSchoolId course) -- join <*> count [CourseParticipantCourseId ==. cid] -- join @@ -93,7 +93,7 @@ getCourseShowR tid csh = do let course = entityVal courseEnt (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerButton $ mbRegistered defaultLayout $ do - setTitle $ [shamlet| #{termToText tid} - #{csh}|] + setTitle $ [shamlet| #{toPathPiece tid} - #{csh}|] $(widgetFile "course") registerButton :: Bool -> Form () @@ -104,11 +104,11 @@ registerButton registered = msg = if registered then "Abmelden" else "Anmelden" regMsg = msg :: BootstrapSubmit Text -postCourseShowR :: TermIdentifier -> Text -> Handler Html +postCourseShowR :: TermId -> Text -> Handler Html postCourseShowR tid csh = do aid <- requireAuthId (cid, registered) <- runDB $ do - (Entity cid _) <- getBy404 $ CourseTermShort (TermKey tid) csh + (Entity cid _) <- getBy404 $ CourseTermShort tid csh registered <- isJust <$> (getBy $ UniqueCourseParticipant cid aid) return (cid, registered) ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerButton registered @@ -133,9 +133,9 @@ getCourseEditR = do postCourseEditR :: Handler Html postCourseEditR = courseEditHandler Nothing -getCourseEditExistR :: TermIdentifier -> Text -> Handler Html +getCourseEditExistR :: TermId -> Text -> Handler Html getCourseEditExistR tid csh = do - course <- runDB $ getBy $ CourseTermShort (TermKey tid) csh + course <- runDB $ getBy $ CourseTermShort tid csh courseEditHandler course getCourseEditExistIDR :: CryptoUUIDCourse -> Handler Html @@ -155,12 +155,12 @@ courseEditHandler course = do | fAct == formActionDelete , Just cid <- cfCourseId res -> do runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen! - let cti = termToText $ cfTerm res + let cti = toPathPiece $ cfTerm res addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|] redirect $ CourseListTermR $ cfTerm res | fAct == formActionSave , Just cid <- cfCourseId res -> do - let tid = TermKey $ cfTerm res + let tid = cfTerm res actTime <- liftIO getCurrentTime updateokay <- runDB $ do exists <- getBy $ CourseTermShort tid $ cfShort res @@ -179,7 +179,7 @@ courseEditHandler course = do , CourseChanged =. actTime ] return upokay - let cti = termToText $ cfTerm res + let cti = toPathPiece $ cfTerm res if updateokay then do addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde geändert. |] @@ -195,7 +195,7 @@ courseEditHandler course = do , courseDescription = cfDesc res , courseLinkExternal = cfLink res , courseShorthand = cfShort res - , courseTermId = TermKey $ cfTerm res + , courseTermId = cfTerm res , courseSchoolId = cfSchool res , courseCapacity = cfCapacity res , courseHasRegistration = cfHasReg res @@ -209,11 +209,11 @@ courseEditHandler course = do case insertOkay of (Just cid) -> do runDB $ insert_ $ Lecturer aid cid - let cti = termToText $ cfTerm res + let cti = toPathPiece $ cfTerm res addMessage "info" [shamlet|Kurs #{cti}/#{cfShort res} wurde angelegt.|] redirect $ CourseListTermR $ cfTerm res Nothing -> do - let cti = termToText $ cfTerm res + let cti = toPathPiece $ cfTerm res addMessage "danger" [shamlet|Es gibt bereits einen Kurs #{cfShort res} in Semester #{cti}.|] (FormFailure _,_) -> addMessage "warning" "Bitte Eingabe korrigieren." _other -> return () @@ -231,7 +231,7 @@ data CourseForm = CourseForm , cfDesc :: Maybe Html , cfLink :: Maybe Text , cfShort :: Text - , cfTerm :: TermIdentifier + , cfTerm :: TermId , cfSchool :: SchoolId , cfCapacity :: Maybe Int , cfHasReg :: Bool @@ -250,7 +250,7 @@ courseToForm cEntity = CourseForm , cfDesc = courseDescription course , cfLink = courseLinkExternal course , cfShort = courseShorthand course - , cfTerm = unTermKey $ courseTermId course + , cfTerm = courseTermId course , cfSchool = courseSchoolId course , cfCapacity = courseCapacity course , cfHasReg = courseHasRegistration course @@ -277,8 +277,8 @@ newCourseForm template = identForm FIDcourse $ \html -> do -- & addAttr "disabled" "disabled" & setTooltip "Muss innerhalb des Semesters eindeutig sein") (cfShort <$> template) - <*> areq termExistsField (fsb "Semester") (cfTerm <$> template) - <*> areq (selectField schools) (fsb "Institut") (cfSchool <$> template) + <*> areq termActiveField (fsb "Semester") (cfTerm <$> template) + <*> areq schoolField (fsb "Institut") (cfSchool <$> template) <*> aopt (natField "Kapazität") (fsb "Kapazität") (cfCapacity <$> template) <*> areq checkBoxField (fsb "Anmeldung") (cfHasReg <$> template) <*> aopt utcTimeField (fsb "Anmeldung von:") (cfRegFrom <$> template) @@ -299,15 +299,11 @@ newCourseForm template = identForm FIDcourse $ \html -> do |] ) _ -> (result, widget) - where +-- where -- cid :: Maybe CourseId -- cid = join $ cfCourseId <$> template --- --- schools :: GHandler UniWorX UniWorX (OptionList SchoolId) - schools = do - entities <- runDB $ selectList [] [Asc SchoolShorthand] - optionsPairs $ map (\school -> (schoolShorthand $ entityVal school, entityKey school)) entities - + + validateCourse :: CourseForm -> [Text] validateCourse (CourseForm{..}) = [ msg | (False, msg) <- diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs new file mode 100644 index 000000000..0eff808f2 --- /dev/null +++ b/src/Handler/CryptoIDDispatch.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE NoImplicitPrelude + , DataKinds + , KindSignatures + , TypeFamilies + , FlexibleInstances + , TypeOperators + , RankNTypes + , PolyKinds + , RecordWildCards + , MultiParamTypeClasses + , ScopedTypeVariables + , ViewPatterns + #-} + +module Handler.CryptoIDDispatch + ( getCryptoUUIDDispatchR + ) where + +import Import hiding (Proxy) + +import Data.Proxy + +import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..)) + +import qualified Control.Monad.Catch as E (Handler(..)) + + +class CryptoRoute ciphertext plaintext where + cryptoIDRoute :: p plaintext -> ciphertext -> Handler (Route UniWorX) + +instance CryptoRoute UUID SubmissionId where + cryptoIDRoute _ (CryptoID -> cID) = do + (_ :: SubmissionId) <- decrypt cID + + return $ SubmissionR cID + + +class Dispatch ciphertext (x :: [*]) where + dispatchID :: p x -> ciphertext -> Handler (Maybe (Route UniWorX)) + +instance Dispatch ciphertext '[] where + dispatchID _ _ = return Nothing + +instance (CryptoRoute ciphertext plaintext, Dispatch ciphertext ps) => Dispatch ciphertext (plaintext ': ps) where + dispatchID _ ciphertext = (<|>) <$> dispatchHead <*> dispatchTail + where + dispatchHead = (Just <$> cryptoIDRoute (Proxy :: Proxy plaintext) ciphertext) `catches` [ E.Handler handleHCError, E.Handler handleCryptoID ] + where + handleHCError :: HandlerContents -> Handler (Maybe a) + handleHCError (HCError NotFound) = return Nothing + handleHCError e = throwM e + handleCryptoID :: CryptoIDError -> Handler (Maybe a) + handleCryptoID _ = return Nothing + dispatchTail = dispatchID (Proxy :: Proxy ps) ciphertext + + +getCryptoUUIDDispatchR :: UUID -> Handler () +getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectWith found302) + where + p :: Proxy '[ SubmissionId + ] + p = Proxy diff --git a/src/Handler/Home.bak b/src/Handler/Home.bak deleted file mode 100644 index 11dec1ca5..000000000 --- a/src/Handler/Home.bak +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -module Handler.Home where - -import Import -import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3) -import Text.Julius (RawJS (..)) - --- Define our data that will be used for creating the form. -data FileForm = FileForm - { fileInfo :: FileInfo - , fileDescription :: Text - } - --- This is a handler function for the GET request method on the HomeR --- resource pattern. All of your resource patterns are defined in --- config/routes --- --- The majority of the code you will write in Yesod lives in these handler --- functions. You can spread them across multiple files if you are so --- inclined, or create a single monolithic file. -getHomeR :: Handler Html -getHomeR = do - (formWidget, formEnctype) <- generateFormPost sampleForm - let submission = Nothing :: Maybe FileForm - handlerName = "getHomeR" :: Text - defaultLayout $ do - let (commentFormId, commentTextareaId, commentListId) = commentIds - aDomId <- newIdent - setTitle "Welcome To Yesod!" - $(widgetFile "homepage") - -postHomeR :: Handler Html -postHomeR = do - ((result, formWidget), formEnctype) <- runFormPost sampleForm - let handlerName = "postHomeR" :: Text - submission = case result of - FormSuccess res -> Just res - _ -> Nothing - - defaultLayout $ do - let (commentFormId, commentTextareaId, commentListId) = commentIds - aDomId <- newIdent - setTitle "Welcome To Yesod!" - $(widgetFile "homepage") - -sampleForm :: Form FileForm -sampleForm = renderBootstrap3 BootstrapBasicForm $ FileForm - <$> fileAFormReq "Choose a file" - <*> areq textField textSettings Nothing - -- Add attributes like the placeholder and CSS classes. - where textSettings = FieldSettings - { fsLabel = "What's on the file?" - , fsTooltip = Nothing - , fsId = Nothing - , fsName = Nothing - , fsAttrs = - [ ("class", "form-control") - , ("placeholder", "File description") - ] - } - -commentIds :: (Text, Text, Text) -commentIds = ("js-commentForm", "js-createCommentTextarea", "js-commentList") diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index a3f3afa4d..4edfaa7bb 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 #-} @@ -8,17 +11,23 @@ module Handler.Sheet where import Import import Handler.Utils +import Handler.Utils.Zip + -- import Data.Time --- import qualified Data.Text as T +import qualified Data.Text as T -- import Data.Function ((&)) --- import Yesod.Form.Bootstrap3 +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 +import qualified Data.Conduit.List as C +import qualified Database.Esqueleto as E + +import Network.Mime {- * Implement Handlers @@ -26,23 +35,203 @@ import Handler.Utils * Implement Access in Foundation -} +data SheetForm = SheetForm + { sfName :: Text + , sfComment :: Maybe Html + , sfType :: SheetType + , sfMarkingText :: Maybe Html + , sfActiveFrom :: UTCTime + , sfActiveTo :: UTCTime + , sfSheetF :: Maybe FileInfo + , sfHintFrom :: Maybe UTCTime + , sfHintF :: Maybe FileInfo + , sfSolutionFrom :: Maybe UTCTime + , sfSolutionF :: Maybe FileInfo + } -getSheetListR :: TermIdentifier -> Text -> Handler Html -getSheetListR _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO -getSheetNewR :: TermIdentifier -> Text -> Handler Html -getSheetNewR _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO +makeSheetForm :: CourseId -> Maybe SheetForm -> Form SheetForm +makeSheetForm cid template = identForm FIDsheet $ \html -> do + -- TODO: Yesod.Form.MassInput.inputList arbeitet Server-seitig :( + -- Erstmal nur mit ZIP arbeiten + (result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ SheetForm + <$> areq textField (fsb "Name") (sfName <$> template) + <*> aopt htmlField (fsb "Hinweise für Teilnehmer") (sfMarkingText <$> template) + <*> sheetTypeAFormReq (fsb "Bewertung") (sfType <$> template) + --TODO: SICHTBARKEIT hinzunehmen + <*> aopt htmlField (fsb "Hinweise für Korrektoren") (sfMarkingText <$> template) + <*> areq utcTimeField (fsb "Abgabe ab") (sfActiveFrom <$> template) + <*> areq utcTimeField (fsb "Abgabefrist") (sfActiveTo <$> template) + <*> fileAFormOpt (fsb "Aufgaben") + <*> aopt utcTimeField (fsb "Hinweis ab") (sfHintFrom <$> template) + <*> fileAFormOpt (fsb "Hinweis") + <*> aopt utcTimeField (fsb "Lösung ab") (sfSolutionFrom <$> template) + <*> fileAFormOpt (fsb "Lösung") + return $ case result of + FormSuccess sheetResult + | errorMsgs <- validateSheet sheetResult + , not $ null errorMsgs -> + (FormFailure errorMsgs, + [whamlet| +
+

Fehler: +