fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

SheetSubmissionMode & generate pseudonyms

Browse Source
This commit is contained in:
Gregor Kleen 2018-10-15 01:04:49 +02:00
parent 4429daef9b
commit 788b53946a
14 changed files with 8426 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8192
config/wordlist.txt Normal file
View File

File diff suppressed because it is too large Load Diff

9
messages/uniworx/de.msg
View File

@ -91,6 +91,7 @@ SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht w
SheetDelOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh}: #{sheetName} gelöscht.
SheetUploadMode: Abgabe von Dateien
SheetSubmissionMode: Abgabe-Modus
SheetExercise: Aufgabenstellung
SheetHint: Hinweis
SheetHintFrom: Hinweis ab
@ -111,6 +112,8 @@ SheetActiveTo: Abgabefrist
SheetHintFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen
SheetSolutionFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen
SheetMarkingTip: Hinweise zur Korrektur, sichtbar nur für Korrektoren
SheetPseudonym: Persönliches Abgabe-Pseudonym
SheetGeneratePseudonym: Generieren
SheetErrVisibility: Sichtbarkeit muss vor Beginn der Abgabefrist liegen
SheetErrDeadlineEarly: Ende der Abgabefrist muss nach deren Beginn liegen
@ -155,6 +158,8 @@ UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben.
UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt.
UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert.
UnauthorizedSubmissionCorrector: Sie sind nicht der Korrektor für diese Abgabe.
UnauthorizedUserSubmission: Nutzer dürfen für dieses Übungsblatt keine Abgaben erstellen.
UnauthorizedCorrectorSubmission: Korrektoren dürfen für dieses Übungsblatt keine Abgaben erstellen.
OnlyUploadOneFile: Bitte nur eine Datei hochladen.
DeprecatedRoute: Diese Ansicht ist obsolet und könnte in Zukunft entfallen.
UnfreeMaterials: Die Materialien für diese Veranstaltung sind nicht allgemein freigegeben.
@ -307,6 +312,10 @@ UploadModeNone: Kein Upload
UploadModeUnpack: Upload, einzelne Datei
UploadModeNoUnpack: Upload, ZIP-Archive entpacken
SheetNoSubmission: Keine Abgabe
SheetCorrectorSubmissions: Abgaben durch Korrektoren
SheetUserSubmissions: Direkte Abgabe
SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen.
FieldPrimary: Hauptfach

7
models
View File

@ -111,11 +111,18 @@ Sheet
hintFrom UTCTime Maybe
solutionFrom UTCTime Maybe
uploadMode UploadMode
submissionMode SheetSubmissionMode default='UserSubmissions'
CourseSheet course name
SheetEdit
user UserId
time UTCTime
sheet SheetId
SheetPseudonym
sheet SheetId
pseudonym Pseudonym
user UserId
UniqueSheetPseudonym sheet pseudonym
UniqueSheetPseudonymUser sheet user
SheetCorrector
user UserId
sheet SheetId

2
package.yaml
View File

@ -93,6 +93,7 @@ dependencies:
- connection
- universe
- universe-base
- random
- random-shuffle
- th-abstraction
- HaskellNet
@ -104,6 +105,7 @@ dependencies:
- aeson-pretty
- resourcet
- postgresql-simple
- word24
# The library contains all of our application code. The executable
# defined below is just a thin wrapper.

3
routes
View File

@ -72,7 +72,7 @@
/edit SEditR GET POST
/delete SDelR GET POST
/subs SSubsR GET POST -- for lecturer only
/subs/new SubmissionNewR GET POST !timeANDregistered
/subs/new SubmissionNewR GET POST !timeANDregisteredANDuser-submissions
/subs/own SubmissionOwnR GET !free -- just redirect
/sub/#CryptoFileNameSubmission SubmissionR !correctorANDisRead:
/ SubShowR GET POST !ownerANDtime !ownerANDisRead
@ -80,6 +80,7 @@
/correction CorrectionR GET POST !corrector !ownerANDisReadANDrated
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner
/correctors SCorrR GET POST
/pseudonym SPseudonymR POST !registeredANDcorrector-submissions
!/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector

16
src/Foundation.hs
View File

@ -481,6 +481,22 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
return Authorized
r -> $unsupportedAuthPredicate "rated" r
)
,("user-submissions", APDB $ \route _ -> case route of
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
guard $ sheetSubmissionMode == UserSubmissions
return Authorized
r -> $unsupportedAuthPredicate "user-submissions" r
)
,("corrector-submissions", APDB $ \route _ -> case route of
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
guard $ sheetSubmissionMode == CorrectorSubmissions
return Authorized
r -> $unsupportedAuthPredicate "corrector-submissions" r
)
,("isRead", APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite))
,("isWrite", APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized))
]

53
src/Handler/Sheet.hs
View File

@ -14,6 +14,7 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE MultiWayIf, LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NamedFieldPuns #-}
module Handler.Sheet where
@ -62,6 +63,12 @@ import Data.Monoid (Sum(..), Any(..))
import Control.Lens
-- import Utils.Lens
import qualified Data.Text as Text
import qualified Data.Aeson as Aeson
import Control.Monad.Random.Class (MonadRandom(..))
import Utils.Sql
instance Eq (Unique Sheet) where
(CourseSheet cid1 name1) == (CourseSheet cid2 name2) =
@ -82,6 +89,7 @@ data SheetForm = SheetForm
, sfVisibleFrom :: Maybe UTCTime
, sfActiveFrom :: UTCTime
, sfActiveTo :: UTCTime
, sfSubmissionMode :: SheetSubmissionMode
, sfUploadMode :: UploadMode
, sfSheetF :: Maybe (Source Handler (Either FileId File))
, sfHintFrom :: Maybe UTCTime
@ -120,6 +128,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
& setTooltip MsgSheetActiveFromTip)
(sfActiveFrom <$> template)
<*> areq utcTimeField (fslI MsgSheetActiveTo) (sfActiveTo <$> template)
<*> areq submissionModeField (fslI MsgSheetSubmissionMode) ((sfSubmissionMode <$> template) <|> pure UserSubmissions)
<*> areq uploadModeField (fslI MsgSheetUploadMode) ((sfUploadMode <$> template) <|> pure (Upload True))
<*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
<*> aopt utcTimeField (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren"
@ -244,6 +253,21 @@ getSheetListR tid ssh csh = do
$(widgetFile "sheetList")
$(widgetFile "widgets/sheetTypeSummary")
data ButtonGeneratePseudonym = BtnGenerate
deriving (Enum, Eq, Ord, Bounded, Read, Show)
instance Universe ButtonGeneratePseudonym
instance Finite ButtonGeneratePseudonym
$(return [])
instance PathPiece ButtonGeneratePseudonym where
toPathPiece = $(nullaryToPathPiece ''ButtonGeneratePseudonym [Text.unwords . drop 1 . splitCamel])
fromPathPiece = finiteFromPathPiece
instance Button UniWorX ButtonGeneratePseudonym where
label BtnGenerate = [whamlet|_{MsgSheetGeneratePseudonym}|]
cssClass BtnGenerate = BCDefault
-- Show single sheet
getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSShowR tid ssh csh shn = do
@ -307,6 +331,12 @@ getSShowR tid ssh csh shn = do
visibleFrom <- traverse (formatTime SelFormatDateTime) $ sheetVisibleFrom sheet
when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI Warning $
maybe MsgSheetInvisible MsgSheetInvisibleUntil visibleFrom
mPseudonym <- runMaybeT $ do
uid <- MaybeT maybeAuthId
Entity _ SheetPseudonym{sheetPseudonymPseudonym} <- MaybeT . runDB . getBy $ UniqueSheetPseudonymUser sid uid
return . Text.unwords . map CI.original $ review pseudonymWords sheetPseudonymPseudonym
(generateWidget, generateEnctype) <- generateFormPost $ \csrf ->
over _2 ((toWidget csrf <>) . fvInput) <$> mreq (buttonField BtnGenerate) "" Nothing
defaultLayout $ do
setTitleI $ MsgSheetTitle tid ssh csh shn
sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet
@ -315,6 +345,26 @@ getSShowR tid ssh csh shn = do
solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet
$(widgetFile "sheetShow")
postSPseudonymR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
postSPseudonymR tid ssh csh shn = do
uid <- requireAuthId
shId <- runDB $ fetchSheetId tid ssh csh shn
let
genPseudonym = do
inserted <- runDB . setSerializable $ do
candidate <- liftIO getRandom
fmap (const candidate) <$> insertUnique (SheetPseudonym shId candidate uid)
case inserted of
Nothing -> genPseudonym
Just ps -> return ps
ps <- genPseudonym
let ps' = Text.unwords . map CI.original $ review pseudonymWords ps
selectRep $ do
provideRep $ return ps'
provideRep . return $ Aeson.String ps'
provideRep (redirect $ CSheetR tid ssh csh shn SShowR :: Handler Html)
getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent
getSFileR tid ssh csh shn typ title = do
results <- runDB $ E.select $ E.from $
@ -366,6 +416,7 @@ getSheetNewR tid ssh csh = do
, sfVisibleFrom = addOneWeek <$> sheetVisibleFrom
, sfActiveFrom = addOneWeek sheetActiveFrom
, sfActiveTo = addOneWeek sheetActiveTo
, sfSubmissionMode = sheetSubmissionMode
, sfUploadMode = sheetUploadMode
, sfSheetF = Nothing
, sfHintFrom = addOneWeek <$> sheetHintFrom
@ -400,6 +451,7 @@ getSEditR tid ssh csh shn = do
, sfVisibleFrom = sheetVisibleFrom
, sfActiveFrom = sheetActiveFrom
, sfActiveTo = sheetActiveTo
, sfSubmissionMode = sheetSubmissionMode
, sfUploadMode = sheetUploadMode
, sfSheetF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise
, sfHintFrom = sheetHintFrom
@ -441,6 +493,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
, sheetHintFrom = sfHintFrom
, sheetSolutionFrom = sfSolutionFrom
, sheetUploadMode = sfUploadMode
, sheetSubmissionMode = sfSubmissionMode
}
mbsid <- dbAction newSheet
case mbsid of

7
src/Handler/Utils/Form.hs
View File

@ -228,6 +228,13 @@ uploadModeField = selectFieldList
, (MsgUploadModeUnpack , Upload True )
]
submissionModeField :: Field Handler SheetSubmissionMode
submissionModeField = selectFieldList
[ (MsgSheetNoSubmission, NoSubmissions)
, (MsgSheetCorrectorSubmissions, CorrectorSubmissions)
, (MsgSheetUserSubmissions, UserSubmissions)
]
zipFileField :: Bool -- ^ Unpack zips?
-> Field Handler (Source Handler File)
zipFileField doUnpack = Field{..}

16
src/Jobs.hs
View File

@ -10,7 +10,6 @@
, QuasiQuotes
, NamedFieldPuns
, MultiWayIf
, NumDecimals
#-}
module Jobs
@ -43,6 +42,7 @@ import Data.Monoid (Last(..))
import Data.Semigroup (Max(..))
import Utils.Lens
import Utils.Sql
import Control.Monad.Random (evalRand, uniform, mkStdGen)
@ -81,9 +81,6 @@ import Data.Time.Zones
import Control.Concurrent.STM (retry)
import Database.PostgreSQL.Simple (sqlErrorHint)
import Control.Monad.Catch (handleIf)
data JobQueueException = JInvalid QueuedJobId QueuedJob
| JLocked QueuedJobId InstanceId UTCTime
@ -346,17 +343,6 @@ runDBJobs act = do
forM_ jIds $ writeJobCtl . JobCtlPerform
return ret
setSerializable :: DB a -> DB a
setSerializable act = setSerializable' (0 :: Integer)
where
act' = [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *> act
setSerializable' (min 10 -> logBackoff) =
handleIf
(\e -> sqlErrorHint e == "The transaction might succeed if retried.")
(\e -> $logWarnS "SQL" (tshow e) *> threadDelay (1e3 * 2 ^ logBackoff) *> setSerializable' (succ logBackoff))
act'
pruneLastExecs :: Crontab JobCtl -> DB ()
pruneLastExecs crontab = runConduit $ selectSource [] [] .| C.mapM_ ensureCrontab
where

59
src/Model/Types.hs
View File

@ -8,6 +8,7 @@
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE BinaryLiterals #-}
{-- # LANGUAGE ExistentialQuantification #-} -- for DA type
{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
@ -74,6 +75,13 @@ import Mail (MailLanguages(..))
import Utils.DateTime (DateTimeFormat(..), SelDateTimeFormat(..))
import Numeric.Natural
import Data.Word.Word24 (Word24)
import Data.Bits
import Data.Ix
import Data.List (genericIndex, elemIndex)
import System.Random (Random(..))
import Model.Types.Wordlist
instance PathPiece UUID where
@ -226,6 +234,16 @@ data UploadMode = NoUpload | Upload { unpackZips :: Bool }
deriveJSON defaultOptions ''UploadMode
derivePersistFieldJSON ''UploadMode
data SheetSubmissionMode = NoSubmissions
| CorrectorSubmissions
| UserSubmissions
deriving (Show, Read, Eq, Ord, Enum, Bounded)
deriveJSON defaultOptions
{ constructorTagModifier = intercalate "-" . map toLower . splitCamel
} ''SheetSubmissionMode
derivePersistField "SheetSubmissionMode"
data ExamStatus = Attended | NoShow | Voided
deriving (Show, Read, Eq, Ord, Enum, Bounded)
derivePersistField "ExamStatus"
@ -241,8 +259,6 @@ deriveJSON defaultOptions ''Load
derivePersistFieldJSON ''Load
instance Semigroup Load where
(Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop')
where
@ -518,6 +534,45 @@ instance ToBackendKey SqlBackend record => Hashable (Key record) where
derivePersistFieldJSON ''MailLanguages
newtype Pseudonym = Pseudonym Word24
deriving (Eq, Ord, Read, Show)
deriving newtype (Bounded, Enum, Integral, Num, Real, Bits, FiniteBits, Ix)
instance PersistField Pseudonym where
toPersistValue p = toPersistValue (fromIntegral p :: Word32)
fromPersistValue = fmap (fromIntegral :: Word32 -> Pseudonym) . fromPersistValue
instance PersistFieldSql Pseudonym where
sqlType _ = SqlInt32
instance Random Pseudonym where
randomR (lo, hi) gen = over _1 (fromIntegral :: Word32 -> Pseudonym) $ randomR (min 0 $ fromIntegral lo, max 0b111111111111 $ fromIntegral hi) gen
random = randomR (0, 0b111111111111)
pseudonymWordlist :: [CI Text]
pseudonymWordlist = $(wordlist "config/wordlist.txt")
pseudonymWords :: Prism' [CI Text] Pseudonym
pseudonymWords = prism' pToWords pFromWords
where
pFromWords :: [CI Text] -> Maybe Pseudonym
pFromWords [w1, w2]
| Just i1 <- elemIndex w1 pseudonymWordlist
, Just i2 <- elemIndex w2 pseudonymWordlist
, i1 <= maxWord, i2 <= maxWord
= Just $ shift (fromIntegral i1) (-12) .|. fromIntegral i2
pFromWords _ = Nothing
pToWords :: Pseudonym -> [CI Text]
pToWords p = [ genericIndex pseudonymWordlist $ shift p 12 .&. maxWord
, genericIndex pseudonymWordlist $ p .&. maxWord
]
maxWord :: Num a => a
maxWord = 0b111111111111
-- Type synonyms
type Email = Text

40
src/Model/Types/Wordlist.hs Normal file
View File

@ -0,0 +1,40 @@
{-# LANGUAGE NoImplicitPrelude
, TemplateHaskell
, ViewPatterns
, OverloadedStrings
#-}
module Model.Types.Wordlist (wordlist) where
import ClassyPrelude hiding (lift)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (qAddDependentFile, Lift(..))
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Data.CaseInsensitive as CI
wordlist :: FilePath -> ExpQ
wordlist file = do
qAddDependentFile file
wordlist' <- runIO $ filter ((||) <$> not . isComment <*> isWord) . Text.lines <$> Text.readFile file
listE $ map (\(Text.unpack -> word) -> [e|CI.mk $ Text.pack $(lift word)|]) wordlist'
isWord :: Text -> Bool
isWord t
| [w] <- Text.words t
, w == t
= True
| otherwise
= False
isComment :: Text -> Bool
isComment line = or
[ commentSymbol `Text.isPrefixOf` Text.stripStart line
, Text.null $ Text.strip line
]
where
commentSymbol = "#"

30
src/Utils/Sql.hs Normal file
View File

@ -0,0 +1,30 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NumDecimals #-}
{-# LANGUAGE FlexibleContexts #-}
module Utils.Sql
( setSerializable
) where
import ClassyPrelude.Yesod
import Database.Persist.Sql
import Database.PostgreSQL.Simple (sqlErrorHint)
import Control.Monad.Catch (handleIf)
setSerializable :: (MonadLogger m, MonadCatch m, MonadBase IO m, MonadIO m) => ReaderT SqlBackend m a -> ReaderT SqlBackend m a
setSerializable act = setSerializable' (0 :: Integer)
where
act' = [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *> act
setSerializable' (min 10 -> logBackoff) =
handleIf
(\e -> sqlErrorHint e == "The transaction might succeed if retried.")
(\e -> $logWarnS "Sql" (tshow e) *> threadDelay (1e3 * 2 ^ logBackoff) *> setSerializable' (succ logBackoff))
act'

2
templates/sheetShow.cassius Normal file
View File

@ -0,0 +1,2 @@
.pseudonym
font-family: monospace

8
templates/sheetShow.hamlet
View File

@ -25,6 +25,14 @@ $maybe marking <- sheetMarkingText sheet
<dd .deflist__dd>#{solution}
<dt .deflist__dt>_{MsgSheetType}
<dd .deflist__dd>_{sheetType sheet}
$if CorrectorSubmissions == sheetSubmissionMode sheet
<dt .deflist__dt>_{MsgSheetPseudonym}
<dd .deflist__dd>
$maybe pseudonym <- mPseudonym
<span .pseudonym>#{pseudonym}
$nothing
<form method=post action=@{CSheetR tid ssh csh shn SPseudonymR} enctype=#{generateEnctype}>
^{generateWidget}
$if hasFiles
<section>