Merge branch 'master' into initial_thoughts_on_frontend
This commit is contained in:
Felix Hamann
commit
50cebd92bf
5
.gitignore
vendored
5
.gitignore
vendored
@ -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
|
||||
|
||||
27
Datenschutznotizen.txt
Normal file
27
Datenschutznotizen.txt
Normal file
@ -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.
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
71
fill-db.hs
Executable file
71
fill-db.hs
Executable file
@ -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
|
||||
8
ghci.sh
Executable file
8
ghci.sh
Executable file
@ -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
|
||||
10
models
10
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)
|
||||
|
||||
@ -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:
|
||||
|
||||
22
routes
22
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
|
||||
|
||||
23
shell.nix
23
shell.nix
@ -1,4 +1,4 @@
|
||||
{ nixpkgs ? import <nixpkgs> {}, compiler ? null }:
|
||||
{ nixpkgs ? import <nixpkgs> {}, 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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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? -}
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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:
|
||||
|
||||
@ -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| <a href=@{CourseShowR tid shd}>#{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) <-
|
||||
|
||||
62
src/Handler/CryptoIDDispatch.hs
Normal file
62
src/Handler/CryptoIDDispatch.hs
Normal file
@ -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
|
||||
@ -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")
|
||||
@ -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|
|
||||
<div class="alert alert-danger">
|
||||
<h4> Fehler:
|
||||
<ul>
|
||||
$forall errmsg <- errorMsgs
|
||||
<li> #{errmsg}
|
||||
^{widget}
|
||||
|]
|
||||
)
|
||||
_ -> (result, widget)
|
||||
where
|
||||
validateSheet _ = [] -- TODO
|
||||
|
||||
getSheetShowR :: TermIdentifier -> Text -> SheetId -> Handler Html
|
||||
getSheetShowR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
|
||||
|
||||
getSheetEditR :: TermIdentifier -> Text -> SheetId -> Handler Html
|
||||
fetchSheet :: TermId -> Text -> Text -> YesodDB UniWorX (Entity Sheet)
|
||||
fetchSheet tid csh shn = do
|
||||
-- TODO: More efficient with Esquleto?
|
||||
(Entity cid _course) <- getBy404 $ CourseTermShort tid csh
|
||||
getBy404 $ CourseSheet cid shn
|
||||
|
||||
-- List Sheets
|
||||
getSheetListCID :: CourseId -> Handler Html
|
||||
getSheetListCID cid = getSheetList =<<
|
||||
(Entity cid) <$> (runDB $ get404 cid)
|
||||
|
||||
getSheetListR :: TermId -> Text -> Handler Html
|
||||
getSheetListR tid csh = getSheetList =<<
|
||||
(runDB $ getBy404 $ CourseTermShort 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 = 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 encodeWidgetTable tableDefault colSheets sheets
|
||||
|
||||
-- Show single sheet
|
||||
getSheetShowR :: TermId -> Text -> Text -> Handler Html
|
||||
getSheetShowR tid csh shn = getSheetShow =<<
|
||||
(runDB $ fetchSheet tid csh shn)
|
||||
|
||||
{- Nur per UUID
|
||||
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
|
||||
[whamlet| Under Construction !!! |] -- TODO
|
||||
$(widgetFile "sheetAdmin")
|
||||
|
||||
getSheetFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent
|
||||
getSheetFileR tid csh shn typ title = do
|
||||
content <- runDB $ E.select $ E.from $
|
||||
\(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
|
||||
-- Restrict to consistent rows that correspond to each other
|
||||
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFileId)
|
||||
E.on (sheetFile E.^. SheetFileSheetId E.==. sheet E.^. SheetId)
|
||||
E.on (sheet E.^. SheetCourseId E.==. course E.^. CourseId)
|
||||
-- filter to requested file
|
||||
E.where_ ((file E.^. FileTitle E.==. E.val title)
|
||||
E.&&. (sheetFile E.^. SheetFileType E.==. E.val typ )
|
||||
E.&&. (sheet E.^. SheetName E.==. E.val shn )
|
||||
E.&&. (course E.^. CourseShorthand E.==. E.val csh )
|
||||
E.&&. (course E.^. CourseTermId E.==. E.val tid )
|
||||
)
|
||||
-- return desired columns
|
||||
return $ file E.^. FileContent
|
||||
let mimeType = defaultMimeLookup $ pack title
|
||||
case content of
|
||||
[E.Value (Just nochmalContent)] -> do
|
||||
addHeader "Content-Disposition" "attachment"
|
||||
respond mimeType nochmalContent
|
||||
[] -> notFound
|
||||
_other -> error "Multiple matching files found."
|
||||
|
||||
getSheetNewR :: TermId -> Text -> Handler Html
|
||||
getSheetNewR tid csh = do
|
||||
(Entity cid course) <- runDB $ getBy404 $ CourseTermShort tid csh
|
||||
let template = Nothing -- TODO: provide convenience by interpolating name/nr/dates+7days
|
||||
((res,wdgt), enc) <- runFormPost $ makeSheetForm cid template
|
||||
|
||||
case res of
|
||||
(FormSuccess SheetForm{..}) -> do
|
||||
|
||||
|
||||
let sid = undefined -- TODO after first insert
|
||||
let sname = undefined -- TODO after first insert
|
||||
|
||||
-- Prüfe, das FileTitle innerhalb des Sheets eindeutig ist für diesen SheetFileTpye
|
||||
whenIsJust sfSheetF $ \sinfo -> do
|
||||
let sheetInsert file = do
|
||||
fid <- insert file
|
||||
void . insert $ SheetFile sid fid SheetExercise
|
||||
runDB . runConduit $ (sourceFiles sinfo) =$= C.mapM_ sheetInsert
|
||||
|
||||
|
||||
|
||||
addMessage "info" "Blatt angelegt"
|
||||
redirect $ SheetShowR tid csh sname
|
||||
(FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
|
||||
_ -> return ()
|
||||
defaultLayout $ do
|
||||
$(widgetFile "newSheet")
|
||||
|
||||
postSheetNewR :: TermId -> Text -> Handler Html
|
||||
postSheetNewR = getSheetNewR
|
||||
|
||||
getSheetEditR :: TermId -> Text -> SheetId -> Handler Html
|
||||
getSheetEditR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
|
||||
|
||||
postSheetEditR :: TermId -> Text -> SheetId -> Handler Html
|
||||
postSheetEditR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
|
||||
|
||||
|
||||
getSheetDelR :: TermId -> Text -> SheetId -> Handler Html
|
||||
getSheetDelR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
|
||||
-- Sicherheitsabfrage
|
||||
|
||||
postSheetDelR :: TermId -> Text -> SheetId -> Handler Html
|
||||
postSheetDelR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
|
||||
-- Tatsächlich löschen
|
||||
|
||||
|
||||
{-
|
||||
getCourseShowR :: TermIdentifier -> Text -> Handler Html
|
||||
getCourseShowR :: TermId -> Text -> Handler Html
|
||||
getCourseShowR tid csh = do
|
||||
mbAid <- maybeAuthId
|
||||
(courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do
|
||||
|
||||
@ -27,8 +27,6 @@ import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as Text
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Data.UUID.Cryptographic as UUID
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import qualified Data.Conduit.List as Conduit
|
||||
@ -38,7 +36,6 @@ import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import System.FilePath
|
||||
import qualified System.FilePath.Cryptographic as FilePath (decrypt, encrypt)
|
||||
|
||||
import Colonnade
|
||||
import Yesod.Colonnade
|
||||
@ -52,12 +49,11 @@ submissionTable = do
|
||||
|
||||
return (sub, sheet, course)
|
||||
|
||||
cIDKey <- getsYesod appCryptoIDKey
|
||||
cryptedSubs <- forM subs $ \s@(Entity submissionId _, _, _) ->
|
||||
(,,) <$> FilePath.encrypt cIDKey submissionId <*> UUID.encrypt cIDKey submissionId <*> pure s
|
||||
(,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s
|
||||
|
||||
let
|
||||
anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseShowR (unTermKey courseTermId) courseShorthand
|
||||
anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseShowR courseTermId courseShorthand
|
||||
courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName
|
||||
anchorSubmission (_, cUUID, _) = SubmissionR cUUID
|
||||
submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID
|
||||
@ -69,7 +65,7 @@ submissionTable = do
|
||||
toExternal :: (CryptoFileNameSubmission, CryptoUUIDSubmission, a) -> Handler CryptoUUIDSubmission
|
||||
toExternal (_, cID, _) = return cID
|
||||
fromExternal :: CryptoUUIDSubmission -> Handler SubmissionId
|
||||
fromExternal = UUID.decrypt cIDKey
|
||||
fromExternal = decrypt
|
||||
headedRowSelector toExternal fromExternal (HA.class_ "table table-striped table-hover") colonnade cryptedSubs
|
||||
|
||||
|
||||
@ -104,10 +100,9 @@ postSubmissionListR = do
|
||||
sinks <- execStateC Map.empty . awaitForever $ \case
|
||||
v@(Right (sId, _)) -> lift $ feed sId v
|
||||
(Left f@File{..}) -> case splitDirectories fileTitle of
|
||||
(cID:rest)
|
||||
(cID:rest)
|
||||
| not (null rest) -> do
|
||||
cIDKey <- getsYesod appCryptoIDKey
|
||||
sId <- FilePath.decrypt cIDKey (CryptoID $ CI.mk cID :: CryptoFileNameSubmission)
|
||||
sId <- decrypt (CryptoID $ CI.mk cID :: CryptoFileNameSubmission)
|
||||
lift . feed sId $ Left f{ fileTitle = joinPath rest }
|
||||
| otherwise -> return ()
|
||||
[] -> invalidArgs ["Encountered file/directory with empty name"]
|
||||
@ -121,9 +116,8 @@ postSubmissionListR = do
|
||||
|
||||
getSubmissionDownloadSingleR :: CryptoUUIDSubmission -> FilePath -> Handler TypedContent
|
||||
getSubmissionDownloadSingleR cID path = do
|
||||
cIDKey <- getsYesod appCryptoIDKey
|
||||
submissionID <- UUID.decrypt cIDKey cID
|
||||
cID' <- FilePath.encrypt cIDKey submissionID
|
||||
submissionID <- decrypt cID
|
||||
cID' <- encrypt submissionID
|
||||
|
||||
runDB $ do
|
||||
isRating <- maybe False (== submissionID) <$> isRatingFile path
|
||||
@ -172,9 +166,7 @@ postSubmissionDownloadMultiArchiveR = do
|
||||
let
|
||||
fileEntitySource' :: (Rating, Entity Submission) -> Source (YesodDB UniWorX) File
|
||||
fileEntitySource' (rating, Entity submissionID Submission{..}) = do
|
||||
cID <- lift $ do
|
||||
cIDKey <- getsYesod appCryptoIDKey
|
||||
FilePath.encrypt cIDKey submissionID
|
||||
cID <- encrypt submissionID
|
||||
|
||||
let
|
||||
directoryName = CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission)
|
||||
@ -202,9 +194,8 @@ getSubmissionDownloadArchiveR path = do
|
||||
cID :: CryptoFileNameSubmission
|
||||
cID = CryptoID $ CI.mk baseName
|
||||
unless (ext == ".zip") notFound
|
||||
cIDKey <- getsYesod appCryptoIDKey
|
||||
submissionID <- FilePath.decrypt cIDKey cID
|
||||
cUUID <- UUID.encrypt cIDKey submissionID
|
||||
submissionID <- decrypt cID
|
||||
cUUID <- encrypt submissionID
|
||||
respondSourceDB "application/zip" $ do
|
||||
rating <- lift $ getRating submissionID
|
||||
case rating of
|
||||
@ -218,8 +209,7 @@ getSubmissionDownloadArchiveR path = do
|
||||
getSubmissionR, postSubmissionR :: CryptoUUIDSubmission -> Handler Html
|
||||
getSubmissionR = postSubmissionR
|
||||
postSubmissionR cID = do
|
||||
cIDKey <- getsYesod appCryptoIDKey
|
||||
submissionId <- UUID.decrypt cIDKey cID
|
||||
submissionId <- decrypt cID
|
||||
|
||||
((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderBootstrap3 BootstrapBasicForm $ (,)
|
||||
<$> areq checkBoxField (bfs ("Dies ist eine Korrektur" :: Text)) (Just False)
|
||||
@ -260,7 +250,7 @@ postSubmissionR cID = do
|
||||
, ratingTime = submissionRatingTime submission
|
||||
}
|
||||
|
||||
cID' <- FilePath.encrypt cIDKey submissionId
|
||||
cID' <- encrypt submissionId
|
||||
let
|
||||
archiveBaseName = CI.foldedCase $ ciphertext (cID' :: CryptoFileNameSubmission)
|
||||
archiveName = archiveBaseName <.> "zip"
|
||||
|
||||
@ -39,12 +39,12 @@ getTermShowR = do
|
||||
provideRep $ return $ toJSON $ map fst termData
|
||||
provideRep $ do
|
||||
let colonnadeTerms = mconcat
|
||||
[ headed "Kürzel" $ \(Entity _ Term{..},_) -> do
|
||||
[ headed "Kürzel" $ \(Entity tid Term{..},_) -> do
|
||||
-- Scrap this if to slow, create term edit page instead
|
||||
adminLink <- handlerToWidget $ isAuthorized (TermEditExistR termName) False
|
||||
adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False
|
||||
[whamlet|
|
||||
$if adminLink == Authorized
|
||||
<a href=@{TermEditExistR termName}>
|
||||
<a href=@{TermEditExistR tid}>
|
||||
#{termToText termName}
|
||||
$else
|
||||
#{termToText termName}
|
||||
@ -55,9 +55,9 @@ getTermShowR = do
|
||||
fromString $ formatTimeGerWD termLectureEnd
|
||||
, headed "Aktiv" $ \(Entity _ Term{..},_) ->
|
||||
bool "" tickmark termActive
|
||||
, headed "Kursliste" $ \(Entity _ Term{..}, E.Value numCourses) ->
|
||||
, headed "Kursliste" $ \(Entity tid Term{..}, E.Value numCourses) ->
|
||||
[whamlet|
|
||||
<a href=@{CourseListTermR termName}>
|
||||
<a href=@{CourseListTermR tid}>
|
||||
#{show numCourses} Kurse
|
||||
|]
|
||||
, headed "Semesteranfang" $ \(Entity _ Term{..},_) ->
|
||||
@ -69,7 +69,7 @@ getTermShowR = do
|
||||
]
|
||||
defaultLayout $ do
|
||||
setTitle "Freigeschaltete Semester"
|
||||
encodeHeadedWidgetTable tableDefault colonnadeTerms termData
|
||||
encodeWidgetTable tableDefault colonnadeTerms termData
|
||||
|
||||
|
||||
getTermEditR :: Handler Html
|
||||
@ -80,9 +80,9 @@ getTermEditR = do
|
||||
postTermEditR :: Handler Html
|
||||
postTermEditR = termEditHandler Nothing
|
||||
|
||||
getTermEditExistR :: TermIdentifier -> Handler Html
|
||||
getTermEditExistR :: TermId -> Handler Html
|
||||
getTermEditExistR tid = do
|
||||
term <- runDB $ get $ TermKey tid
|
||||
term <- runDB $ get tid
|
||||
termEditHandler term
|
||||
|
||||
|
||||
|
||||
45
src/Handler/Users.hs
Normal file
45
src/Handler/Users.hs
Normal file
@ -0,0 +1,45 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Handler.Users where
|
||||
|
||||
import Import
|
||||
-- import Data.Text
|
||||
import Handler.Utils
|
||||
|
||||
import Colonnade hiding (fromMaybe)
|
||||
import Yesod.Colonnade
|
||||
|
||||
-- import qualified Database.Esqueleto as E
|
||||
-- import Database.Esqueleto ((^.))
|
||||
|
||||
|
||||
getUsersR :: Handler Html
|
||||
getUsersR = do
|
||||
-- TODO: Esqueleto, combine the two queries into one
|
||||
(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 $
|
||||
[ 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 = encodeWidgetTable tableDefault colonnadeUsers users
|
||||
$(widgetFile "users")
|
||||
@ -1,5 +1,7 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Handler.Utils
|
||||
( module Handler.Utils
|
||||
@ -18,12 +20,44 @@ import Handler.Utils.Rating as Handler.Utils
|
||||
import Handler.Utils.Submission as Handler.Utils
|
||||
import Handler.Utils.Templates as Handler.Utils
|
||||
|
||||
import Text.Blaze (Markup)
|
||||
import Text.Blaze (Markup, ToMarkup)
|
||||
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
tickmark :: IsString a => a
|
||||
tickmark = fromString "✔"
|
||||
|
||||
text2Html :: Text -> Html
|
||||
text2Html = toHtml -- prevents ambiguous types
|
||||
|
||||
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)
|
||||
|
||||
-----------
|
||||
-- Maybe --
|
||||
-----------
|
||||
whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
|
||||
whenIsJust (Just x) f = f x
|
||||
whenIsJust Nothing _ = return ()
|
||||
|
||||
----------
|
||||
-- Maps --
|
||||
----------
|
||||
entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record
|
||||
entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -219,8 +219,25 @@ minIntField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormM
|
||||
minIntField m d = checkBool (>= m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) $ intField
|
||||
|
||||
|
||||
schoolField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m SchoolId
|
||||
schoolField = undefined -- TODO
|
||||
--termField: see Utils.Term
|
||||
|
||||
schoolField :: Field Handler SchoolId
|
||||
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)
|
||||
@ -229,19 +246,20 @@ utcTimeField = Field
|
||||
, fieldView = \theId name attrs val isReq ->
|
||||
[whamlet|
|
||||
$newline never
|
||||
<input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required value="#{either id showTime val}">
|
||||
<input id="#{theId}" name="#{name}" *{attrs} type="datetime-local" :isReq:required value="#{either id showTime val}">
|
||||
|]
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
where
|
||||
fieldTimeFormat :: String
|
||||
fieldTimeFormat = "%e.%m.%y %k:%M"
|
||||
--fieldTimeFormat = "%e.%m.%y %k:%M"
|
||||
fieldTimeFormat = "%Y-%m-%eT%H:%M"
|
||||
|
||||
readTime :: Text -> Either FormMessage UTCTime
|
||||
readTime t =
|
||||
case parseTimeM True germanTimeLocale fieldTimeFormat (T.unpack t) of
|
||||
(Just time) -> Right time
|
||||
Nothing -> Left $ MsgInvalidEntry "Datum/Zeit Format: tt.mm.yy hh:mm"
|
||||
Nothing -> Left $ MsgInvalidEntry $ "Datum/Zeit Format: tt.mm.yy hh:mm " ++ t
|
||||
|
||||
showTime :: UTCTime -> Text
|
||||
showTime = fromString . (formatTime germanTimeLocale fieldTimeFormat)
|
||||
|
||||
@ -109,7 +109,7 @@ sinkSubmission sheetId userId mExists = do
|
||||
| not (null collidingFiles) = any (/~ file) [ f | (Entity _ f, _) <- collidingFiles ]
|
||||
| otherwise = True
|
||||
matchesUnderlying
|
||||
| not (null underlyingFiles) = all (~~ file) [ f | (Entity _ f, Entity _ sf) <- underlyingFiles ]
|
||||
| not (null underlyingFiles) = all (~~ file) [ f | (Entity _ f, Entity _ _sf) <- underlyingFiles ]
|
||||
| otherwise = False
|
||||
undoneDeletion = any submissionFileIsDeletion [ sf | (_, Entity _ sf) <- collidingFiles ]
|
||||
|
||||
|
||||
@ -36,7 +36,7 @@ pairColonnade a b = mconcat [ lmap fst a, lmap snd b]
|
||||
-- Table Modification
|
||||
encodeHeadedWidgetTableNumbered :: Attribute -> Colonnade Headed a (WidgetT site IO ()) -> [a] -> WidgetT site IO ()
|
||||
encodeHeadedWidgetTableNumbered attrs colo tdata =
|
||||
encodeHeadedWidgetTable attrs (mconcat [numberCol, lmap snd colo]) (zip [1..] tdata)
|
||||
encodeWidgetTable attrs (mconcat [numberCol, lmap snd colo]) (zip [1..] tdata)
|
||||
where
|
||||
numberCol :: Colonnade Headed (Int,a) (WidgetT site IO ())
|
||||
numberCol = headed "Nr" (fromString.show.fst)
|
||||
@ -86,5 +86,5 @@ headedRowSelector toExternal fromExternal attrs colonnade tdata = do
|
||||
collectResult (FormSuccess x:rs) = (x :) <$> collectResult rs
|
||||
|
||||
return ( catMaybes <$> collectResult selectionResults
|
||||
, encodeHeadedCellTable attrs (pairColonnade selColonnade colonnade) (zip [0..] tdata)
|
||||
, encodeCellTable attrs (pairColonnade selColonnade colonnade) (zip [0..] tdata)
|
||||
)
|
||||
|
||||
@ -13,15 +13,14 @@ import Model.Types
|
||||
-- import Data.Maybe
|
||||
|
||||
|
||||
termExistsField :: Field Handler TermIdentifier
|
||||
termExistsField = termField True
|
||||
-- TODO: Change this to an option list of active terms
|
||||
termActiveField :: Field Handler TermId
|
||||
termActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
|
||||
|
||||
termActiveOld :: Field Handler TermIdentifier
|
||||
termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
|
||||
|
||||
termNewField :: Field Handler TermIdentifier
|
||||
termNewField = termField False
|
||||
|
||||
termField :: Bool -> Field Handler TermIdentifier
|
||||
termField mustexist = checkMMap checkTerm termToText textField
|
||||
termNewField = checkMMap checkTerm termToText textField
|
||||
where
|
||||
errTextParse :: Text
|
||||
errTextParse = "Semester: S oder W gefolgt von Jahreszahl"
|
||||
@ -31,12 +30,8 @@ termField mustexist = checkMMap checkTerm termToText textField
|
||||
|
||||
checkTerm :: Text -> HandlerT UniWorX IO (Either Text TermIdentifier)
|
||||
checkTerm t = case termFromText t of
|
||||
Left _ -> return $ Left errTextParse
|
||||
res@(Right ti) -> do
|
||||
term <- runDB $ get $ TermKey ti -- TODO: membershiptest instead?
|
||||
return $ if mustexist && isNothing term
|
||||
then Left $ errTextFreigabe ti
|
||||
else res
|
||||
Left _ -> return $ Left errTextParse
|
||||
res@(Right _) -> return res
|
||||
|
||||
validateTerm :: Term -> [Text]
|
||||
validateTerm (Term{..}) =
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
|
||||
{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- This concerns zipEntrySize in produceZip
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
@ -10,6 +11,7 @@ module Handler.Utils.Zip
|
||||
, produceZip
|
||||
, consumeZip
|
||||
, modifyFileTitle
|
||||
, sourceFiles
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -29,6 +31,8 @@ import Data.Time
|
||||
|
||||
import Data.List (dropWhileEnd)
|
||||
|
||||
import Network.Mime
|
||||
|
||||
|
||||
instance Default ZipInfo where
|
||||
def = ZipInfo
|
||||
@ -93,3 +97,16 @@ produceZip info = mapC toZipData =$= void (zipStream zipOptions)
|
||||
|
||||
modifyFileTitle :: Monad m => (FilePath -> FilePath) -> Conduit File m File
|
||||
modifyFileTitle f = mapC $ \x@File{..} -> x{ fileTitle = f fileTitle }
|
||||
|
||||
-- Takes FileInfo and if it is a ZIP-Archive, extract files, otherwiese yield fileinfo
|
||||
sourceFiles :: (MonadResource m, MonadThrow m, MonadIO m) => FileInfo -> Source m File
|
||||
sourceFiles fInfo
|
||||
| mimeType == "application/zip" = fileSource fInfo =$= void consumeZip
|
||||
| otherwise = do
|
||||
let fileTitle = unpack $ fileName fInfo
|
||||
fileModified <- liftIO getCurrentTime
|
||||
yieldM $ do
|
||||
fileContent <- Just <$> runConduit (fileSource fInfo =$= foldC)
|
||||
return File{..}
|
||||
where
|
||||
mimeType = defaultMimeLookup (fileName fInfo)
|
||||
|
||||
@ -11,6 +11,8 @@ import Yesod.Auth as Import
|
||||
import Yesod.Core.Types as Import (loggerSet)
|
||||
import Yesod.Default.Config2 as Import
|
||||
|
||||
|
||||
import Data.Fixed as Import
|
||||
|
||||
import CryptoID as Import
|
||||
import Data.UUID as Import (UUID)
|
||||
|
||||
@ -4,6 +4,9 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
|
||||
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
|
||||
|
||||
|
||||
module Model.Types where
|
||||
|
||||
import ClassyPrelude
|
||||
@ -22,6 +25,7 @@ import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import Text.Read (readMaybe)
|
||||
import Text.Shakespeare.I18N
|
||||
|
||||
-- import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
@ -36,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 }
|
||||
@ -53,6 +63,16 @@ data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
|
||||
deriving (Show, Read, Eq, Ord, Enum, Bounded)
|
||||
derivePersistField "SheetFileType"
|
||||
|
||||
instance PathPiece SheetFileType where
|
||||
toPathPiece SheetExercise = "file"
|
||||
toPathPiece SheetHint = "hint"
|
||||
toPathPiece SheetSolution = "solution"
|
||||
toPathPiece SheetMarking = "marking"
|
||||
fromPathPiece t =
|
||||
lookup (CI.mk t) [(CI.mk $ toPathPiece ty,ty) | ty <- [minBound..maxBound]]
|
||||
|
||||
|
||||
|
||||
data Load = ByTutorial | ByProportion Double
|
||||
deriving (Show, Read, Eq)
|
||||
derivePersistField "Load"
|
||||
@ -113,6 +133,9 @@ instance ToJSON TermIdentifier where
|
||||
instance FromJSON TermIdentifier where
|
||||
parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText
|
||||
|
||||
instance RenderMessage site TermIdentifier where -- TODO: I18N
|
||||
renderMessage _ _ = termToText
|
||||
|
||||
{- Must be defined in a later module:
|
||||
termField :: Field (HandlerT UniWorX IO) TermIdentifier
|
||||
termField = checkMMap (return . termFromText) termToText textField
|
||||
|
||||
@ -5,7 +5,9 @@ let
|
||||
in haskell.lib.buildStackProject {
|
||||
inherit ghc;
|
||||
name = "stackenv";
|
||||
buildInputs = with pkgs;
|
||||
buildInputs = (with pkgs;
|
||||
[ postgresql zlib openldap cyrus_sasl.dev
|
||||
];
|
||||
]) ++ (with haskell.packages."ghc${builtins.replaceStrings ["."] [""] ghc.version}";
|
||||
[ yesod-bin
|
||||
]);
|
||||
}
|
||||
|
||||
58
stack.yaml
58
stack.yaml
@ -1,4 +1,5 @@
|
||||
flags: {}
|
||||
|
||||
docker:
|
||||
enable: false
|
||||
image: uniworx
|
||||
@ -6,33 +7,40 @@ nix:
|
||||
packages: []
|
||||
pure: false
|
||||
shell-file: ./stack.nix
|
||||
|
||||
extra-package-dbs: []
|
||||
|
||||
packages:
|
||||
- .
|
||||
- location:
|
||||
git: https://github.com/pngwjpgh/zip-stream.git
|
||||
commit: 9272bbed000928d500febad1cdc98d1da29d399e
|
||||
extra-dep: true
|
||||
- location:
|
||||
git: https://github.com/mlitchard/yesod-auth-ldap.git
|
||||
commit: 69e08ef687ab96df3352ff4267562135453c6f02
|
||||
extra-dep: true
|
||||
- location:
|
||||
git: https://github.com/mlitchard/authenticate-ldap.git
|
||||
commit: cc2770024766a8fa29d3086688df60aaf65fb954
|
||||
extra-dep: true
|
||||
- .
|
||||
- location:
|
||||
git: https://github.com/pngwjpgh/zip-stream.git
|
||||
commit: 9272bbed000928d500febad1cdc98d1da29d399e
|
||||
extra-dep: true
|
||||
- location:
|
||||
git: https://github.com/mlitchard/yesod-auth-ldap.git
|
||||
commit: 69e08ef687ab96df3352ff4267562135453c6f02
|
||||
extra-dep: true
|
||||
- location:
|
||||
git: https://github.com/mlitchard/authenticate-ldap.git
|
||||
commit: cc2770024766a8fa29d3086688df60aaf65fb954
|
||||
extra-dep: true
|
||||
- location:
|
||||
git: https://github.com/pngwjpgh/encoding.git
|
||||
commit: 67bb87ceff53f0178c988dd4e15eeb2daee92b84
|
||||
extra-dep: true
|
||||
|
||||
extra-deps:
|
||||
- colonnade-1.1.1
|
||||
- yesod-colonnade-1.1.0
|
||||
# - zip-stream-0.1.0.1
|
||||
- conduit-resumablesink-0.2
|
||||
- uuid-crypto-1.3.1.0
|
||||
- filepath-crypto-0.0.0.0
|
||||
- cryptoids-0.4.0.0
|
||||
- cryptoids-types-0.0.0
|
||||
- colonnade-1.2.0
|
||||
- yesod-colonnade-1.2.0
|
||||
|
||||
- encoding-0.8.2
|
||||
- regex-compat-0.93.1
|
||||
- conduit-resumablesink-0.2
|
||||
|
||||
- LDAP-0.6.11
|
||||
resolver: lts-9.3
|
||||
- uuid-crypto-1.4.0.0
|
||||
- filepath-crypto-0.1.0.0
|
||||
- cryptoids-0.5.0.0
|
||||
- cryptoids-types-0.0.0
|
||||
- cryptoids-class-0.0.0
|
||||
|
||||
- LDAP-0.6.11
|
||||
|
||||
resolver: lts-10.5
|
||||
|
||||
10
start.sh
10
start.sh
@ -1,2 +1,8 @@
|
||||
#!/bin/bash
|
||||
env DUMMY_LOGIN=true stack exec -- yesod devel
|
||||
#!/usr/bin/env bash
|
||||
|
||||
unset HOST
|
||||
export DETAILED_LOGGING=true
|
||||
export LOG_ALL=true
|
||||
export DUMMY_LOGIN=true
|
||||
|
||||
exec -- stack exec -- yesod devel
|
||||
|
||||
@ -24,6 +24,11 @@
|
||||
#{participants}
|
||||
$maybe capacity <- courseCapacity course
|
||||
\ von #{capacity}
|
||||
<br>
|
||||
$maybe regFrom <- courseRegisterFrom course
|
||||
Anmeldezeitraum: #{formatTimeGerWD regFrom}
|
||||
$maybe regTo <- courseRegisterTo course
|
||||
\ bis #{formatTimeGerWD regTo}
|
||||
<form method=post action=@{CourseShowR tid csh} enctype=#{regEnctype}>
|
||||
^{regWidget}
|
||||
|
||||
|
||||
@ -27,16 +27,23 @@
|
||||
<h2>Teilweise funktionierende Abschnitte
|
||||
|
||||
<ul>
|
||||
<li>
|
||||
<li .list-group-item>
|
||||
<a href=@{UsersR}>Benutzer Verwaltung
|
||||
|
||||
<li .list-group-item>
|
||||
<a href=@{TermShowR}>Semester Verwaltung
|
||||
<li>
|
||||
|
||||
<li .list-group-item>
|
||||
<a href=@{CourseEditR}>Kurse anlegen, editieren und anzeigen
|
||||
|
||||
<li .list-group-item>
|
||||
<a href=@{SubmissionListR}>Dateien hochladen und abrufen
|
||||
|
||||
<div>
|
||||
<h2>Funktionen zum Testen
|
||||
|
||||
<ul>
|
||||
<li>
|
||||
Institut einmalig in Datenbank einfügen:
|
||||
Knopf-Test:
|
||||
<form .form-inline method=post action=@{HomeR} enctype=#{btnEnctype}>
|
||||
^{btnWdgt}
|
||||
|
||||
20
templates/newSheet.hamlet
Normal file
20
templates/newSheet.hamlet
Normal file
@ -0,0 +1,20 @@
|
||||
<div .container>
|
||||
<div .bs-docs-section>
|
||||
<div .row>
|
||||
<div .col-lg-12>
|
||||
<div .page-header>
|
||||
<h1 #forms>Neuen Blatt anlegen:
|
||||
|
||||
<p>
|
||||
Bitte alles ausfüllen!
|
||||
|
||||
<div .row>
|
||||
<div .col-lg-6>
|
||||
<div .bs-callout bs-callout-info well>
|
||||
<form .form-horizontal method=post #forms enctype=#{enc}>
|
||||
^{wdgt}
|
||||
|
||||
<button .btn.btn-primary type="submit">
|
||||
Blatt anlegen
|
||||
|
||||
|
||||
30
templates/sheetAdmin.hamlet
Normal file
30
templates/sheetAdmin.hamlet
Normal file
@ -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 <- sheetDescription sheet
|
||||
<h2 #description>Hinweise
|
||||
<p> #{descr}
|
||||
<h3>Bewertung
|
||||
<p> #{show $ sheetType sheet}
|
||||
$maybe marking <- sheetMarkingText sheet
|
||||
<p> #{marking}
|
||||
<br>
|
||||
Freigeschaltet ab:
|
||||
\ #{formatTimeGerWD $ sheetActiveFrom sheet}
|
||||
\ Abgabe bis:
|
||||
\ #{formatTimeGerWD $ sheetActiveTo sheet}
|
||||
|
||||
<div .row>
|
||||
<div .col-lg-12>
|
||||
<h2>Abgaben
|
||||
|
||||
<hr>
|
||||
|
||||
8
templates/users.hamlet
Normal file
8
templates/users.hamlet
Normal file
@ -0,0 +1,8 @@
|
||||
<div .ui.container>
|
||||
|
||||
<p .bg-danger>
|
||||
This page is only for development purposes.
|
||||
|
||||
<h1>
|
||||
User list
|
||||
^{userList}
|
||||
Loading…
Reference in New Issue
Block a user