feat(personalised-sheet-files): introduce routes & work on crypto
This commit is contained in:
Gregor Kleen
parent
5e584048f5
commit
9ee44aa2f1
@ -227,3 +227,6 @@ token-buckets:
|
||||
depth: 1572864000 # 1500MiB
|
||||
inv-rate: 1.9e-6 # 2MiB/s
|
||||
initial-value: 0
|
||||
|
||||
|
||||
fallback-personalised-sheet-files-keys-expire: 2419200
|
||||
|
||||
@ -1340,6 +1340,8 @@ MenuAllocationPriorities: Zentrale Dringlichkeiten
|
||||
MenuAllocationCompute: Platzvergabe berechnen
|
||||
MenuAllocationAccept: Platzvergabe akzeptieren
|
||||
MenuFaq: FAQ
|
||||
MenuSheetPersonalisedFiles: Personalisierte Dateien herunterladen
|
||||
MenuCourseSheetPersonalisedFiles: Vorlage für personalisierte Übungsblatt-Dateien herunterladen
|
||||
|
||||
BreadcrumbSubmissionFile: Datei
|
||||
BreadcrumbSubmissionUserInvite: Einladung zur Abgabe
|
||||
@ -1411,6 +1413,8 @@ BreadcrumbAllocationCompute: Platzvergabe berechnen
|
||||
BreadcrumbAllocationAccept: Platzvergabe akzeptieren
|
||||
BreadcrumbMessageHide: Verstecken
|
||||
BreadcrumbFaq: FAQ
|
||||
BreadcrumbSheetPersonalisedFiles: Personalisierte Dateien herunterladen
|
||||
BreadcrumbCourseSheetPersonalisedFiles: Vorlage für personalisierte Übungsblatt-Dateien herunterladen
|
||||
|
||||
ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn}
|
||||
ExternalExamGrades coursen@CourseName examn@ExamName: Prüfungsleistungen: #{coursen}, #{examn}
|
||||
@ -2664,4 +2668,19 @@ SubmissionDoneNever: Nie
|
||||
SubmissionDoneByFile: Je nach Bewertungsdatei
|
||||
SubmissionDoneAlways: Immer
|
||||
CorrUploadSubmissionDoneMode: Bewertung abgeschlossen
|
||||
CorrUploadSubmissionDoneModeTip: Sollen hochgeladene Korrekturen als abgeschlossen markiert werden? Bewertungen sind erst für Studierende sichtbar und zählen gegen Examboni, wenn sie abgeschlossen sind.
|
||||
CorrUploadSubmissionDoneModeTip: Sollen hochgeladene Korrekturen als abgeschlossen markiert werden? Bewertungen sind erst für Studierende sichtbar und zählen gegen Examboni, wenn sie abgeschlossen sind.
|
||||
|
||||
SheetPersonalisedFiles: Personalisierte Dateien
|
||||
SheetPersonalisedFilesTip: Sollen zusätzlich zu den oben angegebenen Dateien noch pro Kursteilnehmer personalisierte Dateien hinterlegt werden? Nur die jeweiligen Kursteilnehmer können ihre jeweiligen personalisierten Dateien einsehen.
|
||||
SheetPersonalisedFilesUpload: Personalisierte Dateien
|
||||
SheetPersonalisedFilesUploadTip: Laden Sie das Vorlage-Archiv herunter, sortieren Sie darin die personalisierten Dateien in die jeweiligen Verzeichnise der Kursteilnehmer ein und laden sie das Archiv dann hier wieder hoch.
|
||||
SheetPersonalisedFilesKeepExisting: Bestehende Dateien behalten
|
||||
SheetPersonalisedFilesKeepExistingTip: Sollen die hier neu hochgeladenen personalisierten Dateien zu den bestehenden (sofern vorhanden) hinzugefügt werden? Ansonsten werden die bestehenden Dateien vollständig durch die neu hochgeladenen ersetzt.
|
||||
SheetPersonalisedFilesAllowNonPersonalisedSubmission: Nicht-personalisierte Abgabe erlauben
|
||||
SheetPersonalisedFilesAllowNonPersonalisedSubmissionTip: Sollen auch Kursteilnehmer abgeben dürfen, für die keine personalisierten Dateien hinterlegt wurden?
|
||||
SheetPersonalisedFilesDownloadTemplateHere: Sie können hier ein Vorlage-Archiv für die vom System erwartete Verzeichnisstruktur für personalisierte Übungsblatt-Dateien herunterladen:
|
||||
PersonalisedSheetFilesDownloadAnonymous: Anonymisiert
|
||||
PersonalisedSheetFilesDownloadSurnames: Mit Nachnamen
|
||||
PersonalisedSheetFilesDownloadMatriculations: Mit Matrikelnummern
|
||||
PersonalisedSheetFilesDownloadGroups: Mit festen Abgabegruppen
|
||||
CoursePersonalisedSheetFilesArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-personalisierte_dateien
|
||||
@ -14,6 +14,7 @@ Sheet -- exercise sheet for a given course
|
||||
autoDistribute Bool default=false -- Should correctors be assigned submissions automagically?
|
||||
anonymousCorrection Bool default=true
|
||||
requireExamRegistration ExamId Maybe -- Students may only submit if they are registered for the given exam
|
||||
allowNonPersonalisedSubmission Bool default=true
|
||||
CourseSheet course name
|
||||
deriving Generic
|
||||
SheetEdit -- who edited when a row in table "Course", kept indefinitely
|
||||
@ -44,3 +45,18 @@ SheetFile -- a file that is part of an exercise sheet
|
||||
content FileContentReference Maybe
|
||||
modified UTCTime
|
||||
UniqueSheetFile sheet type title
|
||||
PersonalisedSheetFile
|
||||
sheet SheetId
|
||||
user UserId
|
||||
type SheetFileType
|
||||
title FilePath
|
||||
content FileContentReference Maybe
|
||||
modified UTCTime
|
||||
UniquePersonalisedSheetFile sheet user type title
|
||||
|
||||
FallbackPersonalisedSheetFilesKey
|
||||
course CourseId
|
||||
index Word24
|
||||
secret ByteString
|
||||
generated UTCTime
|
||||
UniqueFallbackPersonalisedSheetFilesKey course index
|
||||
@ -42,6 +42,7 @@ dependencies:
|
||||
- cryptonite-conduit
|
||||
- saltine
|
||||
- base64-bytestring
|
||||
- base32
|
||||
- memory
|
||||
- http-api-data
|
||||
- profunctors
|
||||
|
||||
2
routes
2
routes
@ -165,6 +165,7 @@
|
||||
/iscorrector SIsCorrR GET !corrector -- Route is used to check for corrector access to this sheet
|
||||
/pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissionsANDexam-registered
|
||||
/corrector-invite/ SCorrInviteR GET POST
|
||||
/personalised-files SPersonalFilesR GET
|
||||
!/#SheetFileType SZipR GET !timeANDcourse-registeredANDexam-registered !timeANDmaterialsANDexam-registered !corrector !timeANDtutor
|
||||
!/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registeredANDexam-registered !timeANDmaterialsANDexam-registered !corrector !timeANDtutor
|
||||
/file MaterialListR GET !course-registered !materials !corrector !tutor
|
||||
@ -214,6 +215,7 @@
|
||||
/events/#CryptoUUIDCourseEvent CourseEventR:
|
||||
/edit CEvEditR GET POST
|
||||
/delete CEvDeleteR GET POST
|
||||
/personalised-sheet-files CPersonalFilesR GET
|
||||
|
||||
|
||||
/subs CorrectionsR GET POST !corrector !lecturer
|
||||
|
||||
@ -74,6 +74,8 @@ decCryptoIDs [ ''SubmissionId
|
||||
, ''TutorialId
|
||||
]
|
||||
|
||||
decCryptoIDKeySize
|
||||
|
||||
-- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission"
|
||||
instance {-# OVERLAPS #-} PathPiece (E.CryptoID "Submission" (CI FilePath)) where
|
||||
fromPathPiece (Text.unpack -> piece) = do
|
||||
@ -91,3 +93,21 @@ instance {-# OVERLAPS #-} FromJSONKey (E.CryptoID "Submission" (CI FilePath)) wh
|
||||
fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece
|
||||
instance {-# OVERLAPS #-} ToMarkup (E.CryptoID "Submission" (CI FilePath)) where
|
||||
toMarkup = toMarkup . toPathPiece
|
||||
|
||||
-- CryptoIDNamespace (CI FilePath) UserId ~ "User"
|
||||
instance {-# OVERLAPS #-} PathPiece (E.CryptoID "User" (CI FilePath)) where
|
||||
fromPathPiece (Text.unpack -> piece) = do
|
||||
piece' <- (stripPrefix `on` map CI.mk) "uwb" piece
|
||||
return . CryptoID . CI.mk $ map CI.original piece'
|
||||
toPathPiece = Text.pack . ("uwb" <>) . CI.foldedCase . ciphertext
|
||||
|
||||
instance {-# OVERLAPS #-} ToJSON (E.CryptoID "User" (CI FilePath)) where
|
||||
toJSON = String . toPathPiece
|
||||
instance {-# OVERLAPS #-} ToJSONKey (E.CryptoID "User" (CI FilePath)) where
|
||||
toJSONKey = ToJSONKeyText toPathPiece (text . toPathPiece)
|
||||
instance {-# OVERLAPS #-} FromJSON (E.CryptoID "User" (CI FilePath)) where
|
||||
parseJSON = withText "CryptoFileNameUser" $ maybe (fail "Could not parse CryptoFileNameUser") return . fromPathPiece
|
||||
instance {-# OVERLAPS #-} FromJSONKey (E.CryptoID "User" (CI FilePath)) where
|
||||
fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoFileNameUser") return . fromPathPiece
|
||||
instance {-# OVERLAPS #-} ToMarkup (E.CryptoID "User" (CI FilePath)) where
|
||||
toMarkup = toMarkup . toPathPiece
|
||||
|
||||
@ -15,6 +15,9 @@ import qualified Data.Binary as Binary
|
||||
|
||||
import Database.Persist.Sql
|
||||
|
||||
import qualified Data.CryptoID.ByteString as CryptoID.BS
|
||||
import Crypto.Cipher.Types (cipherKeySize, KeySizeSpecifier(..))
|
||||
|
||||
|
||||
decCryptoIDs :: [Name] -> DecsQ
|
||||
decCryptoIDs = fmap concat . mapM decCryptoID
|
||||
@ -45,3 +48,13 @@ decCryptoIDs = fmap concat . mapM decCryptoID
|
||||
where
|
||||
ns = (\nb -> fromMaybe nb $ stripSuffix "Id" nb) $ nameBase n
|
||||
cryptoIDSyn (ct, str) = tySynD (mkName $ "Crypto" ++ str ++ ns) [] $ conT ''CryptoID `appT` return ct `appT` t
|
||||
|
||||
decCryptoIDKeySize :: DecsQ
|
||||
decCryptoIDKeySize = sequence
|
||||
[ tySynD (mkName "CryptoIDCipherKeySize") [] . litT . numTyLit $ fromIntegral cryptoIDKeySize
|
||||
]
|
||||
where
|
||||
cryptoIDKeySize = case cipherKeySize (error "Cipher inspected during cipherKeySize" :: CryptoID.BS.CryptoCipher) of
|
||||
KeySizeRange mins maxs -> max mins maxs
|
||||
KeySizeEnum ss -> maximumEx ss
|
||||
KeySizeFixed s -> s
|
||||
|
||||
58
src/Data/Word/Word24/Instances.hs
Normal file
58
src/Data/Word/Word24/Instances.hs
Normal file
@ -0,0 +1,58 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Data.Word.Word24.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
import Database.Persist
|
||||
import Database.Persist.Sql
|
||||
import System.Random (Random(..))
|
||||
|
||||
import Data.Aeson (FromJSON(..), ToJSON(..))
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
|
||||
import Data.Word.Word24
|
||||
|
||||
import Control.Lens
|
||||
|
||||
import Control.Monad.Fail
|
||||
|
||||
import qualified Data.Scientific as Scientific
|
||||
|
||||
import Data.Binary
|
||||
import Data.Bits
|
||||
|
||||
|
||||
instance PersistField Word24 where
|
||||
toPersistValue p = toPersistValue (fromIntegral p :: Word32)
|
||||
fromPersistValue v = do
|
||||
w <- fromPersistValue v :: Either Text Word32
|
||||
if
|
||||
| 0 <= w
|
||||
, w <= fromIntegral (maxBound :: Word24)
|
||||
-> return $ fromIntegral w
|
||||
| otherwise
|
||||
-> Left "Word24 out of range"
|
||||
|
||||
instance PersistFieldSql Word24 where
|
||||
sqlType _ = SqlInt32
|
||||
|
||||
instance Random Word24 where
|
||||
randomR (max minBound -> lo, min maxBound -> hi) gen = over _1 (fromIntegral :: Word32 -> Word24) $ randomR (fromIntegral lo, fromIntegral hi) gen
|
||||
random = randomR (minBound, maxBound)
|
||||
|
||||
instance FromJSON Word24 where
|
||||
parseJSON (Aeson.Number n) = case Scientific.toBoundedInteger n of
|
||||
Just n' -> return n'
|
||||
Nothing -> fail "parsing Word24 failed, out of range or not integral"
|
||||
parseJSON _ = fail "parsing Word24 failed, expected Number"
|
||||
|
||||
instance ToJSON Word24 where
|
||||
toJSON = Aeson.Number . fromIntegral
|
||||
|
||||
|
||||
-- | Big Endian
|
||||
instance Binary Word24 where
|
||||
put w = forM_ [2,1..0] $ putWord8 . fromIntegral . shiftR w . (* 8)
|
||||
get = foldlM (\w i -> (.|. w) . flip shiftL (8 * i) . fromIntegral <$> getWord8) 0 [2,1..0]
|
||||
@ -2548,6 +2548,7 @@ instance YesodBreadcrumbs UniWorX where
|
||||
SCorrInviteR -> i18nCrumb MsgBreadcrumbSheetCorrectorInvite . Just $ CSheetR tid ssh csh shn SShowR
|
||||
SZipR sft -> i18nCrumb sft . Just $ CSheetR tid ssh csh shn SShowR
|
||||
SFileR _ _ -> i18nCrumb MsgBreadcrumbSheetFile . Just $ CSheetR tid ssh csh shn SShowR
|
||||
SPersonalFilesR -> i18nCrumb MsgBreadcrumbSheetPersonalisedFiles . Just $ CSheetR tid ssh csh shn SShowR
|
||||
|
||||
breadcrumb (CourseR tid ssh csh MaterialListR) = i18nCrumb MsgMenuMaterialList . Just $ CourseR tid ssh csh CShowR
|
||||
breadcrumb (CourseR tid ssh csh MaterialNewR ) = i18nCrumb MsgMenuMaterialNew . Just $ CourseR tid ssh csh MaterialListR
|
||||
@ -2560,6 +2561,8 @@ instance YesodBreadcrumbs UniWorX where
|
||||
MArchiveR -> i18nCrumb MsgBreadcrumbMaterialArchive . Just $ CMaterialR tid ssh csh mnm MShowR
|
||||
MFileR _ -> i18nCrumb MsgBreadcrumbMaterialFile . Just $ CMaterialR tid ssh csh mnm MShowR
|
||||
|
||||
breadcrumb (CourseR tid ssh csh CPersonalFilesR) = i18nCrumb MsgBreadcrumbCourseSheetPersonalisedFiles . Just $ CourseR tid ssh csh CShowR
|
||||
|
||||
breadcrumb CorrectionsR = i18nCrumb MsgMenuCorrections Nothing
|
||||
breadcrumb CorrectionsUploadR = i18nCrumb MsgMenuCorrectionsUpload $ Just CorrectionsR
|
||||
breadcrumb CorrectionsCreateR = i18nCrumb MsgMenuCorrectionsCreate $ Just CorrectionsR
|
||||
@ -3982,6 +3985,32 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do
|
||||
, navSubmissions
|
||||
] ++ guardOnM (not showSubmissions) [ NavPageActionPrimary{ navLink, navChildren = [] } | navLink <- subsSecondary ] ++
|
||||
[ NavPageActionPrimary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = MsgMenuSheetPersonalisedFiles
|
||||
, navRoute = CSheetR tid ssh csh shn SPersonalFilesR
|
||||
, navAccess' =
|
||||
let onlyPersonalised = fmap (maybe False $ not . E.unValue) . E.selectMaybe . E.from $ \(sheet `E.InnerJoin` course) -> do
|
||||
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
||||
E.where_$ sheet E.^. SheetName E.==. E.val shn
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
return $ sheet E.^. SheetAllowNonPersonalisedSubmission
|
||||
hasPersonalised = E.selectExists . E.from $ \(sheet `E.InnerJoin` course `E.InnerJoin` personalisedSheetFile) -> do
|
||||
E.on $ personalisedSheetFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId
|
||||
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
||||
E.where_$ sheet E.^. SheetName E.==. E.val shn
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
in runDB $ or2M onlyPersonalised hasPersonalised
|
||||
, navType = NavTypeLink { navModal = True }
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
}
|
||||
, navChildren = []
|
||||
}
|
||||
, NavPageActionPrimary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = MsgMenuSheetEdit
|
||||
, navRoute = CSheetR tid ssh csh shn SEditR
|
||||
|
||||
@ -19,6 +19,7 @@ import Handler.Course.Application as Handler.Course
|
||||
import Handler.ExamOffice.Course as Handler.Course
|
||||
import Handler.Course.News as Handler.Course
|
||||
import Handler.Course.Events as Handler.Course
|
||||
import Handler.Sheet.PersonalisedFiles as Handler.Course (getCPersonalFilesR)
|
||||
|
||||
|
||||
getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
|
||||
@ -18,6 +18,7 @@ import Handler.Sheet.Current as Handler.Sheet
|
||||
import Handler.Sheet.Download as Handler.Sheet
|
||||
import Handler.Sheet.New as Handler.Sheet
|
||||
import Handler.Sheet.Show as Handler.Sheet
|
||||
import Handler.Sheet.PersonalisedFiles as Handler.Sheet (getSPersonalFilesR)
|
||||
|
||||
|
||||
getSIsCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
|
||||
@ -16,18 +16,20 @@ import qualified Data.Map as Map
|
||||
|
||||
import Handler.Sheet.Form
|
||||
import Handler.Sheet.CorrectorInvite
|
||||
import Handler.Sheet.PersonalisedFiles
|
||||
|
||||
|
||||
getSEditR, postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSEditR = postSEditR
|
||||
postSEditR tid ssh csh shn = do
|
||||
(Entity sid Sheet{..}, sheetFileIds, currentLoads) <- runDB $ do
|
||||
(Entity sid Sheet{..}, sheetFileIds, currentLoads, hasPersonalisedFiles) <- runDB $ do
|
||||
ent@(Entity sid _) <- fetchSheet tid ssh csh shn
|
||||
fti <- getFtIdMap $ entityKey ent
|
||||
cLoads <- Map.union
|
||||
<$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (InvDBDataSheetCorrector sheetCorrectorLoad sheetCorrectorState, InvTokenDataSheetCorrector)) (selectList [ SheetCorrectorSheet ==. sid ] [])
|
||||
<*> fmap (fmap (, InvTokenDataSheetCorrector) . Map.mapKeysMonotonic Left) (sourceInvitationsF sid)
|
||||
return (ent, fti, cLoads)
|
||||
hasPersonalisedFiles <- exists [ PersonalisedSheetFileSheet ==. sid ]
|
||||
return (ent, fti, cLoads, hasPersonalisedFiles)
|
||||
let template = Just $ SheetForm
|
||||
{ sfName = sheetName
|
||||
, sfDescription = sheetDescription
|
||||
@ -48,6 +50,11 @@ postSEditR tid ssh csh shn = do
|
||||
, sfAnonymousCorrection = sheetAnonymousCorrection
|
||||
, sfCorrectors = currentLoads
|
||||
, sfRequireExamRegistration = sheetRequireExamRegistration
|
||||
, sfPersonalF = guardOn (hasPersonalisedFiles || not sheetAllowNonPersonalisedSubmission) SheetPersonalisedFilesForm
|
||||
{ spffFilesKeepExisting = hasPersonalisedFiles
|
||||
, spffAllowNonPersonalisedSubmission = sheetAllowNonPersonalisedSubmission
|
||||
, spffFiles = Nothing
|
||||
}
|
||||
}
|
||||
|
||||
let action = uniqueReplace sid -- More specific error message for edit old sheet could go here by using myReplaceUnique instead
|
||||
@ -79,6 +86,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
|
||||
, sheetAutoDistribute = sfAutoDistribute
|
||||
, sheetAnonymousCorrection = sfAnonymousCorrection
|
||||
, sheetRequireExamRegistration = sfRequireExamRegistration
|
||||
, sheetAllowNonPersonalisedSubmission = fromMaybe True $ spffAllowNonPersonalisedSubmission <$> sfPersonalF
|
||||
}
|
||||
mbsid <- dbAction newSheet
|
||||
case mbsid of
|
||||
@ -88,6 +96,9 @@ handleSheetEdit tid ssh csh msId template dbAction = do
|
||||
insertSheetFile' sid SheetHint $ fromMaybe (return ()) sfHintF
|
||||
insertSheetFile' sid SheetSolution $ fromMaybe (return ()) sfSolutionF
|
||||
insertSheetFile' sid SheetMarking $ fromMaybe (return ()) sfMarkingF
|
||||
runConduit $
|
||||
maybe (return ()) (transPipe liftHandler) (spffFiles =<< sfPersonalF)
|
||||
.| sinkPersonalisedSheetFiles cid (Just sid) (fromMaybe False $ spffFilesKeepExisting <$> sfPersonalF)
|
||||
insert_ $ SheetEdit aid actTime sid
|
||||
addMessageI Success $ MsgSheetEditOk tid ssh csh sfName
|
||||
-- Sanity checks generating warnings only, but not errors!
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
module Handler.Sheet.Form
|
||||
( SheetForm(..), Loads
|
||||
( SheetForm(..), SheetPersonalisedFilesForm(..), Loads
|
||||
, makeSheetForm
|
||||
, getFtIdMap
|
||||
) where
|
||||
@ -29,6 +29,7 @@ data SheetForm = SheetForm
|
||||
, sfDescription :: Maybe Html
|
||||
, sfRequireExamRegistration :: Maybe ExamId
|
||||
, sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe FileUploads
|
||||
, sfPersonalF :: Maybe SheetPersonalisedFilesForm
|
||||
, sfVisibleFrom :: Maybe UTCTime
|
||||
, sfActiveFrom :: Maybe UTCTime
|
||||
, sfActiveTo :: Maybe UTCTime
|
||||
@ -44,6 +45,12 @@ data SheetForm = SheetForm
|
||||
-- Keine SheetId im Formular!
|
||||
}
|
||||
|
||||
data SheetPersonalisedFilesForm = SheetPersonalisedFilesForm
|
||||
{ spffFiles :: Maybe FileUploads
|
||||
, spffFilesKeepExisting :: Bool
|
||||
, spffAllowNonPersonalisedSubmission :: Bool
|
||||
}
|
||||
|
||||
|
||||
getFtIdMap :: Key Sheet -> DB (SheetFileType -> Set FileReference)
|
||||
getFtIdMap sId = do
|
||||
@ -59,6 +66,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS
|
||||
(Just sId) -> liftHandler $ runDB $ getFtIdMap sId
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
ctime <- ceilingQuarterHour <$> liftIO getCurrentTime
|
||||
sheetPersonalisedFilesForm <- makeSheetPersonalisedFilesForm $ template >>= sfPersonalF
|
||||
flip (renderAForm FormStandard) html $ SheetForm
|
||||
<$> areq (textField & cfStrip & cfCI) (fslI MsgSheetName) (sfName <$> template)
|
||||
<*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template)
|
||||
@ -69,6 +77,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS
|
||||
<*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
|
||||
<*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarkingFiles
|
||||
& setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template)
|
||||
<*> optionalActionA sheetPersonalisedFilesForm (fslI MsgSheetPersonalisedFiles & setTooltip MsgSheetPersonalisedFilesTip) (is _Just . sfPersonalF <$> template)
|
||||
<* aformSection MsgSheetFormTimes
|
||||
<*> aopt utcTimeField (fslI MsgSheetVisibleFrom
|
||||
& setTooltip MsgSheetVisibleFromTip)
|
||||
@ -90,6 +99,25 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS
|
||||
<*> apopt checkBoxField (fslI MsgSheetAnonymousCorrection & setTooltip MsgSheetAnonymousCorrectionTip) (sfAnonymousCorrection <$> template)
|
||||
<*> correctorForm (fromMaybe mempty $ sfCorrectors <$> template)
|
||||
where
|
||||
makeSheetPersonalisedFilesForm :: Maybe SheetPersonalisedFilesForm -> MForm Handler (AForm Handler SheetPersonalisedFilesForm)
|
||||
makeSheetPersonalisedFilesForm template' = do
|
||||
templateDownloadMessage <- runMaybeT . hoist (liftHandler . runDB) $ do
|
||||
Sheet{..} <- MaybeT . fmap join $ traverse get msId
|
||||
Course{..} <- MaybeT $ get cId
|
||||
let downloadRoute = CSheetR courseTerm courseSchool courseShorthand sheetName SPersonalFilesR
|
||||
guardM $ hasReadAccessTo downloadRoute
|
||||
messageIconWidget Info IconFileZip
|
||||
[whamlet|
|
||||
$newline never
|
||||
_{MsgSheetPersonalisedFilesDownloadTemplateHere}<br />
|
||||
^{modal (i18n MsgMenuSheetPersonalisedFiles) (Left (SomeRoute downloadRoute))}
|
||||
|]
|
||||
return $ SheetPersonalisedFilesForm
|
||||
<$ maybe (pure ()) aformMessage templateDownloadMessage
|
||||
<*> aopt (zipFileField True Nothing) (fslI MsgSheetPersonalisedFilesUpload & setTooltip MsgSheetPersonalisedFilesUploadTip) Nothing
|
||||
<*> apopt checkBoxField (fslI MsgSheetPersonalisedFilesKeepExisting & setTooltip MsgSheetPersonalisedFilesKeepExistingTip) (fmap spffFilesKeepExisting template' <|> Just True)
|
||||
<*> apopt checkBoxField (fslI MsgSheetPersonalisedFilesAllowNonPersonalisedSubmission & setTooltip MsgSheetPersonalisedFilesAllowNonPersonalisedSubmissionTip) (fmap spffAllowNonPersonalisedSubmission template' <|> Just True)
|
||||
|
||||
validateSheet :: FormValidator SheetForm Handler ()
|
||||
validateSheet = do
|
||||
SheetForm{..} <- State.get
|
||||
|
||||
@ -65,6 +65,7 @@ postSheetNewR tid ssh csh = do
|
||||
, sfCorrectors = loads
|
||||
, sfAnonymousCorrection = sheetAnonymousCorrection
|
||||
, sfRequireExamRegistration = Nothing
|
||||
, sfPersonalF = Nothing
|
||||
}
|
||||
_other -> Nothing
|
||||
let action = -- More specific error message for new sheet could go here, if insertUnique returns Nothing
|
||||
|
||||
220
src/Handler/Sheet/PersonalisedFiles.hs
Normal file
220
src/Handler/Sheet/PersonalisedFiles.hs
Normal file
@ -0,0 +1,220 @@
|
||||
{-# OPTIONS_GHC -Wno-error=redundant-constraints -Wno-error=unused-top-binds -Wno-error=deprecations #-}
|
||||
|
||||
module Handler.Sheet.PersonalisedFiles
|
||||
( sinkPersonalisedSheetFiles
|
||||
, getSPersonalFilesR, getCPersonalFilesR
|
||||
, PersonalisedSheetFilesKeyException(..)
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
|
||||
import qualified Crypto.MAC.KMAC as Crypto
|
||||
import qualified Data.ByteArray as BA
|
||||
import qualified Data.Binary as Binary
|
||||
import Crypto.Hash.Algorithms (SHAKE256)
|
||||
|
||||
import Data.ByteString.Lazy.Base32
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Language.Haskell.TH (nameBase)
|
||||
|
||||
import qualified Data.CryptoID.ByteString as CryptoID
|
||||
import qualified Data.CryptoID.Class.ImplicitNamespace as I
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import Text.Unidecode (unidecode)
|
||||
import Data.Char (isAlphaNum)
|
||||
|
||||
import GHC.Stack
|
||||
|
||||
|
||||
resolvePersonalisedSheetFiles
|
||||
:: forall a m.
|
||||
( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> Lens' a FilePath
|
||||
-> CourseId
|
||||
-> Maybe SheetId
|
||||
-> ConduitT a (Either a (a, FileReferenceResidual PersonalisedSheetFile)) m ()
|
||||
resolvePersonalisedSheetFiles fpL _cid _mbsid = do
|
||||
C.mapM $ \fRef -> maybeT (return $ Left fRef) . fmap (Right . swap) . flip runStateT fRef . zoom fpL $ do
|
||||
error "not implemented" :: StateT FilePath (MaybeT m) (FileReferenceResidual PersonalisedSheetFile)
|
||||
|
||||
|
||||
sinkPersonalisedSheetFiles :: forall m.
|
||||
( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> CourseId
|
||||
-> Maybe SheetId
|
||||
-> Bool -- ^ Keep existing?
|
||||
-> ConduitT FileReference Void (SqlPersistT m) ()
|
||||
sinkPersonalisedSheetFiles cid mbsid _keep
|
||||
= resolvePersonalisedSheetFiles _fileReferenceTitle cid mbsid
|
||||
.| error "not implemented"
|
||||
|
||||
|
||||
data PersonalisedSheetFilesDownloadAnonymous
|
||||
= PersonalisedSheetFilesDownloadAnonymous
|
||||
| PersonalisedSheetFilesDownloadSurnames
|
||||
| PersonalisedSheetFilesDownloadMatriculations
|
||||
| PersonalisedSheetFilesDownloadGroups
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite)
|
||||
nullaryPathPiece ''PersonalisedSheetFilesDownloadAnonymous $ camelToPathPiece' 4
|
||||
embedRenderMessage ''UniWorX ''PersonalisedSheetFilesDownloadAnonymous id
|
||||
|
||||
sourcePersonalisedSheetFiles :: forall m.
|
||||
( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
, MonadRandom m
|
||||
)
|
||||
=> CourseId
|
||||
-> Maybe SheetId
|
||||
-> PersonalisedSheetFilesDownloadAnonymous
|
||||
-> ConduitT () (Either PersonalisedSheetFile File) (SqlPersistT m) ()
|
||||
sourcePersonalisedSheetFiles cId mbsid anonMode = do
|
||||
(mbIdx, cIDKey) <- lift . newPersonalisedFilesKey $ maybe (Left cId) Right mbsid
|
||||
let
|
||||
genSuffixes uid = case anonMode of
|
||||
PersonalisedSheetFilesDownloadGroups -> do
|
||||
subGroups <- E.select . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do
|
||||
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
|
||||
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cId
|
||||
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
|
||||
return $ submissionGroup E.^. SubmissionGroupName
|
||||
return . nub . sort $ map (filter isAlphaNum . foldMap unidecode . unpack . CI.original . E.unValue) subGroups
|
||||
otherAnon
|
||||
| Just f <- userFeature otherAnon -> do
|
||||
features <- E.select . E.from $ \user -> do
|
||||
E.where_ $ user E.^. UserId E.==. E.val uid
|
||||
return $ f user
|
||||
return . sort $ mapMaybe (fmap (filter isAlphaNum . foldMap unidecode . unpack) . E.unValue) features
|
||||
_other -> return mempty
|
||||
where userFeature PersonalisedSheetFilesDownloadSurnames
|
||||
= Just $ E.just . (E.^. UserSurname)
|
||||
userFeature PersonalisedSheetFilesDownloadMatriculations
|
||||
= Just $ E.castString . (E.^. UserMatrikelnummer)
|
||||
userFeature _
|
||||
= Nothing
|
||||
|
||||
sqlSource = E.selectSource . E.from $ \(courseParticipant `E.LeftOuterJoin` personalisedSheetFile) -> do
|
||||
E.on $ E.just (courseParticipant E.^. CourseParticipantUser) E.==. personalisedSheetFile E.?. PersonalisedSheetFileUser
|
||||
E.&&. E.val mbsid E.==. personalisedSheetFile E.?. PersonalisedSheetFileSheet
|
||||
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val cId
|
||||
return (courseParticipant, personalisedSheetFile)
|
||||
|
||||
toRefs = awaitForever $ \(Entity _ CourseParticipant{..}, mbPFile) -> do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
suffix <- do
|
||||
sufCache <- uses _sufCache $ Map.lookup courseParticipantUser
|
||||
case sufCache of
|
||||
Just suf -> return suf
|
||||
Nothing -> do
|
||||
suf <- lift . lift $ genSuffixes courseParticipantUser
|
||||
_sufCache %= Map.insert courseParticipantUser suf
|
||||
return suf
|
||||
cID <- either throwM return . (runReaderT ?? cIDKey) $ I.encrypt courseParticipantUser
|
||||
let dirName = unpack . Text.intercalate "_" . map pack $ suffix `snoc` mkPersonalisedFilesDirectory mbIdx cID
|
||||
unlessM (uses _dirCache $ Set.member dirName) $ do
|
||||
yield $ Right File
|
||||
{ fileTitle = dirName
|
||||
, fileContent = Nothing
|
||||
, fileModified = courseParticipantRegistration
|
||||
}
|
||||
forM_ [SheetExercise, SheetHint, SheetSolution] $ \sfType ->
|
||||
yield $ Right File
|
||||
{ fileTitle = dirName </> unpack (mr $ SheetArchiveFileTypeDirectory sfType)
|
||||
, fileContent = Nothing
|
||||
, fileModified = courseParticipantRegistration
|
||||
}
|
||||
-- TODO: meta.yml
|
||||
_dirCache %= Set.insert dirName
|
||||
whenIsJust mbPFile $ \(Entity _ pFile@PersonalisedSheetFile{..}) -> do
|
||||
let dirName' = dirName </> unpack (mr $ SheetArchiveFileTypeDirectory personalisedSheetFileType)
|
||||
yield . Left $ over (_FileReference . _1 . _fileReferenceTitle) (dirName' </>) pFile
|
||||
where
|
||||
_sufCache :: Lens' _ _
|
||||
_sufCache = _1
|
||||
_dirCache :: Lens' _ _
|
||||
_dirCache = _2
|
||||
|
||||
|
||||
sqlSource .| evalStateC (Map.empty, Set.empty) toRefs
|
||||
|
||||
|
||||
data PersonalisedSheetFilesKeyException
|
||||
= PersonalisedSheetFilesKeyCouldNotDecodeRandom
|
||||
| FallbackPersonalisedSheetFilesKeysExhausted
|
||||
| PersonalisedSheetFilesKeyInsufficientContext
|
||||
| PersonalisedSheetFilesKeyNotFound
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving anyclass (Exception)
|
||||
|
||||
newPersonalisedFilesKey :: forall m.
|
||||
( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m, MonadRandom m
|
||||
, HasCallStack
|
||||
)
|
||||
=> Either CourseId SheetId -> SqlPersistT m (Maybe Word24, CryptoIDKey)
|
||||
newPersonalisedFilesKey (Right shId) = cryptoIDKey $ \cIDKey -> fmap (Nothing,) $
|
||||
either (const $ throwM PersonalisedSheetFilesKeyCouldNotDecodeRandom) (views _3 return) . Binary.decodeOrFail . fromStrict . BA.convert $
|
||||
Crypto.kmac @(SHAKE256 CryptoIDCipherKeySize) (encodeUtf8 . (pack :: String -> Text) $ nameBase 'newPersonalisedFilesKey) (toStrict $ Binary.encode shId) cIDKey
|
||||
newPersonalisedFilesKey (Left cId) = do
|
||||
now <- liftIO getCurrentTime
|
||||
secret <- CryptoID.genKey
|
||||
let secret' = toStrict $ Binary.encode secret
|
||||
firstN <- getRandom
|
||||
traceM $ "newPersonalisedFilesKey: " <> prettyCallStack callStack
|
||||
|
||||
let loop :: Word24 -> SqlPersistT m (Maybe Word24, CryptoIDKey)
|
||||
loop n = do
|
||||
traceM "insertUnique"
|
||||
didInsert <- is _Just <$> insertUnique (FallbackPersonalisedSheetFilesKey cId n secret' now)
|
||||
if | didInsert
|
||||
-> return (Just n, secret)
|
||||
| (firstN == minBound && n == maxBound)
|
||||
|| n == pred firstN
|
||||
-> throwM FallbackPersonalisedSheetFilesKeysExhausted
|
||||
| n == maxBound
|
||||
-> loop minBound
|
||||
| otherwise
|
||||
-> loop $ succ n
|
||||
in loop firstN
|
||||
|
||||
getPersonalisedFilesKey :: CourseId -> Maybe SheetId -> Maybe Word24 -> DB CryptoIDKey
|
||||
getPersonalisedFilesKey _ Nothing Nothing = throwM PersonalisedSheetFilesKeyInsufficientContext
|
||||
getPersonalisedFilesKey _ (Just shId) Nothing = view _2 <$> newPersonalisedFilesKey (Right shId)
|
||||
getPersonalisedFilesKey cId _ (Just idx) = maybeT (throwM PersonalisedSheetFilesKeyNotFound) $ do
|
||||
Entity _ FallbackPersonalisedSheetFilesKey{..} <- MaybeT . getBy $ UniqueFallbackPersonalisedSheetFilesKey cId idx
|
||||
either (const $ throwM PersonalisedSheetFilesKeyCouldNotDecodeRandom) (views _3 return) . Binary.decodeOrFail . fromStrict $ BA.convert fallbackPersonalisedSheetFilesKeySecret
|
||||
|
||||
mkPersonalisedFilesDirectory :: Maybe Word24 -> CryptoFileNameUser -> FilePath
|
||||
mkPersonalisedFilesDirectory Nothing cID = unpack $ toPathPiece cID
|
||||
mkPersonalisedFilesDirectory (Just idx) cID = unpack $ toPathPiece cID <> "-" <> CI.foldCase (toStrict . encodeBase32Unpadded $ Binary.encode idx)
|
||||
|
||||
resolvePersonalisedFilesDirectory :: FilePath -> [(Maybe Word24, CryptoFileNameUser)]
|
||||
resolvePersonalisedFilesDirectory = error "not implemented"
|
||||
|
||||
|
||||
getSPersonalFilesR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
|
||||
getSPersonalFilesR = error "not implemented"
|
||||
|
||||
getCPersonalFilesR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
|
||||
getCPersonalFilesR tid ssh csh = do
|
||||
cId <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCoursePersonalisedSheetFilesArchiveName tid ssh csh
|
||||
serveZipArchive' archiveName $ sourcePersonalisedSheetFiles cId Nothing PersonalisedSheetFilesDownloadAnonymous -- TODO: get Form for anonymisiation
|
||||
@ -60,7 +60,7 @@ serveSomeFiles archiveName source = serveSomeFiles' archiveName $ source .| C.ma
|
||||
|
||||
serveSomeFiles' :: forall file. HasFileReference file => FilePath -> ConduitT () (Either file File) (YesodDB UniWorX) () -> Handler TypedContent
|
||||
serveSomeFiles' archiveName source = do
|
||||
results <- runDB . runConduit $ source .| peekN 2
|
||||
(source', results) <- runDB $ runPeekN 2 source
|
||||
|
||||
$logDebugS "serveSomeFiles" . tshow $ length results
|
||||
|
||||
@ -71,14 +71,17 @@ serveSomeFiles' archiveName source = do
|
||||
setContentDisposition' $ Just archiveName
|
||||
respondSourceDB typeZip $ do
|
||||
let zipComment = T.encodeUtf8 $ pack archiveName
|
||||
source .| eitherC sourceFiles' (C.map id) .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
|
||||
source' .| eitherC sourceFiles' (C.map id) .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
|
||||
|
||||
-- | Serve any number of files as a zip-archive of files, identified through a given DB query
|
||||
--
|
||||
-- Like `serveSomeFiles`, but always sends a zip-archive, even if a single file is returned
|
||||
serveZipArchive :: forall file. HasFileReference file => FilePath -> ConduitT () file (YesodDB UniWorX) () -> Handler TypedContent
|
||||
serveZipArchive archiveName source = do
|
||||
results <- runDB . runConduit $ source .| peekN 1
|
||||
serveZipArchive archiveName source = serveZipArchive' archiveName $ source .| C.map Left
|
||||
|
||||
serveZipArchive' :: forall file. HasFileReference file => FilePath -> ConduitT () (Either file File) (YesodDB UniWorX) () -> Handler TypedContent
|
||||
serveZipArchive' archiveName source = do
|
||||
(source', results) <- runDB $ runPeekN 1 source
|
||||
|
||||
$logDebugS "serveZipArchive" . tshow $ length results
|
||||
|
||||
@ -88,7 +91,7 @@ serveZipArchive archiveName source = do
|
||||
setContentDisposition' $ Just archiveName
|
||||
respondSourceDB typeZip $ do
|
||||
let zipComment = T.encodeUtf8 $ pack archiveName
|
||||
source .| sourceFiles' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
|
||||
source' .| eitherC sourceFiles' (C.map id) .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
|
||||
|
||||
|
||||
-- | Prefix a message with a short course id,
|
||||
|
||||
@ -972,7 +972,7 @@ genericFileField mkOpts = Field{..}
|
||||
)
|
||||
.| C.map (\(fileReferenceTitle, (fileReferenceContent, fileReferenceModified, _)) -> FileReference{..})
|
||||
mapM_ handleFile (bool (take 1) id fieldMultiple files) .| transPipe runDB (handleUpload opts mIdent)
|
||||
(unsealConduitT -> fSrc', length -> nFiles) <- liftHandler $ fSrc $$+ peekN 2
|
||||
(fSrc', length -> nFiles) <- liftHandler $ runPeekN 2 fSrc
|
||||
$logDebugS "genericFileField.fieldParse" $ tshow nFiles
|
||||
if
|
||||
| nFiles <= 0 -> return Nothing
|
||||
|
||||
@ -339,6 +339,10 @@ submissionMultiArchive anonymous (Set.toList -> ids) = do
|
||||
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
|
||||
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val submissionID
|
||||
E.where_ $ E.subSelectForeign submissionUser SubmissionUserSubmission (\submission -> E.subSelectForeign submission SubmissionSheet (E.^. SheetGrouping)) E.==. E.val RegisteredGroups
|
||||
E.where_ . E.exists . E.from $ \(submission `E.InnerJoin` sheet) -> do
|
||||
E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
||||
E.where_ $ submission E.^. SubmissionId E.==. E.val submissionID
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. submissionGroup E.^. SubmissionGroupCourse
|
||||
return $ submissionGroup E.^. SubmissionGroupName
|
||||
let asciiGroups = nub . sort $ map (filter isAlphaNum . foldMap unidecode . unpack . CI.original . E.unValue) groups
|
||||
return . intercalate "_" $ asciiGroups `snoc` fp
|
||||
|
||||
@ -164,6 +164,7 @@ import Network.HTTP.Types.Method.Instances as Import ()
|
||||
import Crypto.Random.Instances as Import ()
|
||||
import Network.Minio.Instances as Import ()
|
||||
import System.Clock.Instances as Import ()
|
||||
import Data.Word.Word24.Instances as Import ()
|
||||
|
||||
import Crypto.Hash as Import (Digest, SHA3_256, SHA3_512)
|
||||
import Crypto.Random as Import (ChaChaDRG, Seed)
|
||||
@ -184,6 +185,8 @@ import Data.Encoding.UTF8 as Import (UTF8(UTF8))
|
||||
|
||||
import GHC.TypeLits as Import (KnownSymbol)
|
||||
|
||||
import Data.Word.Word24 as Import
|
||||
|
||||
|
||||
import Control.Monad.Trans.RWS (RWST)
|
||||
|
||||
|
||||
@ -61,6 +61,7 @@ import Jobs.Handler.SynchroniseLdap
|
||||
import Jobs.Handler.PruneInvitations
|
||||
import Jobs.Handler.ChangeUserDisplayEmail
|
||||
import Jobs.Handler.Files
|
||||
import Jobs.Handler.PersonalisedSheetFiles
|
||||
|
||||
import Jobs.HealthReport
|
||||
|
||||
|
||||
@ -78,6 +78,17 @@ determineCrontab = execWriterT $ do
|
||||
, cronNotAfter = Right CronNotScheduled
|
||||
}
|
||||
|
||||
oldestFallbackPersonalisedSheetFilesKey <- lift $ preview (_head . _entityVal . _fallbackPersonalisedSheetFilesKeyGenerated) <$> selectList [] [Asc FallbackPersonalisedSheetFilesKeyGenerated, LimitTo 1]
|
||||
whenIsJust oldestFallbackPersonalisedSheetFilesKey $ \oldest -> tell $ HashMap.singleton
|
||||
(JobCtlQueue JobPruneFallbackPersonalisedSheetFilesKeys)
|
||||
Cron
|
||||
{ cronInitial = CronTimestamp . utcToLocalTime $ addUTCTime appFallbackPersonalisedSheetFilesKeysExpire oldest
|
||||
, cronRepeat = CronRepeatOnChange
|
||||
, cronRateLimit = appFallbackPersonalisedSheetFilesKeysExpire / 2
|
||||
, cronNotAfter = Right CronNotScheduled
|
||||
}
|
||||
|
||||
|
||||
whenIsJust (appInjectFiles <* appUploadCacheConf) $ \iInterval ->
|
||||
tell $ HashMap.singleton
|
||||
(JobCtlQueue JobInjectFiles)
|
||||
|
||||
15
src/Jobs/Handler/PersonalisedSheetFiles.hs
Normal file
15
src/Jobs/Handler/PersonalisedSheetFiles.hs
Normal file
@ -0,0 +1,15 @@
|
||||
module Jobs.Handler.PersonalisedSheetFiles
|
||||
( dispatchJobPruneFallbackPersonalisedSheetFilesKeys
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Database.Persist.Sql (deleteWhereCount)
|
||||
|
||||
|
||||
dispatchJobPruneFallbackPersonalisedSheetFilesKeys :: JobHandler UniWorX
|
||||
dispatchJobPruneFallbackPersonalisedSheetFilesKeys = JobHandlerAtomic . hoist lift $ do
|
||||
now <- liftIO getCurrentTime
|
||||
expires <- getsYesod $ view _appFallbackPersonalisedSheetFilesKeysExpire
|
||||
n <- deleteWhereCount [ FallbackPersonalisedSheetFilesKeyGenerated <. addUTCTime (- expires) now ]
|
||||
$logInfoS "PruneFallbackPersonalisedSheetFilesKeys" [st|Deleted #{n} expired fallback personalised sheet files keys|]
|
||||
@ -81,6 +81,7 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
|
||||
| JobPruneSessionFiles
|
||||
| JobPruneUnreferencedFiles
|
||||
| JobInjectFiles
|
||||
| JobPruneFallbackPersonalisedSheetFilesKeys
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
|
||||
| NotificationSheetActive { nSheet :: SheetId }
|
||||
|
||||
44
src/Model.hs
44
src/Model.hs
@ -122,14 +122,14 @@ instance HasFileReference SheetFile where
|
||||
}
|
||||
, SheetFileResidual
|
||||
{ sheetFileResidualSheet = sheetFileSheet
|
||||
, sheetFileResidualType = sheetFileType
|
||||
, sheetFileResidualType = sheetFileType
|
||||
}
|
||||
)
|
||||
)
|
||||
(\( FileReference{..}
|
||||
, SheetFileResidual{..}
|
||||
) -> SheetFile
|
||||
{ sheetFileSheet = sheetFileResidualSheet
|
||||
{ sheetFileSheet = sheetFileResidualSheet
|
||||
, sheetFileType = sheetFileResidualType
|
||||
, sheetFileTitle = fileReferenceTitle
|
||||
, sheetFileContent = fileReferenceContent
|
||||
@ -137,9 +137,45 @@ instance HasFileReference SheetFile where
|
||||
}
|
||||
)
|
||||
|
||||
fileReferenceTitleField = SheetFileTitle
|
||||
fileReferenceContentField = SheetFileContent
|
||||
fileReferenceTitleField = SheetFileTitle
|
||||
fileReferenceContentField = SheetFileContent
|
||||
fileReferenceModifiedField = SheetFileModified
|
||||
|
||||
instance HasFileReference PersonalisedSheetFile where
|
||||
data FileReferenceResidual PersonalisedSheetFile = PersonalisedSheetFileResidual
|
||||
{ personalisedSheetFileResidualSheet :: SheetId
|
||||
, personalisedSheetFileResidualUser :: UserId
|
||||
, personalisedSheetFileResidualType :: SheetFileType
|
||||
}
|
||||
|
||||
_FileReference
|
||||
= iso (\PersonalisedSheetFile{..} -> ( FileReference
|
||||
{ fileReferenceTitle = personalisedSheetFileTitle
|
||||
, fileReferenceContent = personalisedSheetFileContent
|
||||
, fileReferenceModified = personalisedSheetFileModified
|
||||
}
|
||||
, PersonalisedSheetFileResidual
|
||||
{ personalisedSheetFileResidualSheet = personalisedSheetFileSheet
|
||||
, personalisedSheetFileResidualUser = personalisedSheetFileUser
|
||||
, personalisedSheetFileResidualType = personalisedSheetFileType
|
||||
}
|
||||
)
|
||||
)
|
||||
(\( FileReference{..}
|
||||
, PersonalisedSheetFileResidual{..}
|
||||
) -> PersonalisedSheetFile
|
||||
{ personalisedSheetFileSheet = personalisedSheetFileResidualSheet
|
||||
, personalisedSheetFileUser = personalisedSheetFileResidualUser
|
||||
, personalisedSheetFileType = personalisedSheetFileResidualType
|
||||
, personalisedSheetFileTitle = fileReferenceTitle
|
||||
, personalisedSheetFileContent = fileReferenceContent
|
||||
, personalisedSheetFileModified = fileReferenceModified
|
||||
}
|
||||
)
|
||||
|
||||
fileReferenceTitleField = PersonalisedSheetFileTitle
|
||||
fileReferenceContentField = PersonalisedSheetFileContent
|
||||
fileReferenceModifiedField = PersonalisedSheetFileModified
|
||||
|
||||
instance HasFileReference SubmissionFile where
|
||||
data FileReferenceResidual SubmissionFile = SubmissionFileResidual
|
||||
|
||||
@ -15,8 +15,6 @@ import qualified Data.Aeson.Types as Aeson
|
||||
|
||||
import Database.Persist.Sql
|
||||
|
||||
import Data.Word.Word24
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Data.Text as Text
|
||||
@ -55,26 +53,9 @@ type PseudonymWord = CI Text
|
||||
|
||||
newtype Pseudonym = Pseudonym Word24
|
||||
deriving (Eq, Ord, Read, Show, Generic, Data)
|
||||
deriving newtype (Bounded, Enum, Integral, Num, Real, Ix)
|
||||
|
||||
|
||||
instance PersistField Pseudonym where
|
||||
toPersistValue p = toPersistValue (fromIntegral p :: Word32)
|
||||
fromPersistValue v = do
|
||||
w <- fromPersistValue v :: Either Text Word32
|
||||
if
|
||||
| 0 <= w
|
||||
, w <= fromIntegral (maxBound :: Pseudonym)
|
||||
-> return $ fromIntegral w
|
||||
| otherwise
|
||||
-> Left "Pseudonym out of range"
|
||||
|
||||
instance PersistFieldSql Pseudonym where
|
||||
sqlType _ = SqlInt32
|
||||
|
||||
instance Random Pseudonym where
|
||||
randomR (max minBound -> lo, min maxBound -> hi) gen = over _1 (fromIntegral :: Word32 -> Pseudonym) $ randomR (fromIntegral lo, fromIntegral hi) gen
|
||||
random = randomR (minBound, maxBound)
|
||||
deriving newtype ( Bounded, Enum, Integral, Num, Real, Ix
|
||||
, PersistField, PersistFieldSql, Random
|
||||
)
|
||||
|
||||
instance FromJSON Pseudonym where
|
||||
parseJSON v@(Aeson.Number _) = do
|
||||
|
||||
@ -177,6 +177,8 @@ data AppSettings = AppSettings
|
||||
|
||||
, appPersistentTokenBuckets :: TokenBucketIdent -> TokenBucketConf
|
||||
|
||||
, appFallbackPersonalisedSheetFilesKeysExpire :: NominalDiffTime
|
||||
|
||||
, appInitialInstanceID :: Maybe (Either FilePath UUID)
|
||||
, appRibbon :: Maybe Text
|
||||
} deriving Show
|
||||
@ -555,6 +557,8 @@ instance FromJSON AppSettings where
|
||||
appUploadCacheConf <- assertM (not . null . Minio.connectHost) <$> o .:? "upload-cache"
|
||||
appUploadCacheBucket <- o .: "upload-cache-bucket"
|
||||
|
||||
appFallbackPersonalisedSheetFilesKeysExpire <- o .: "fallback-personalised-sheet-files-keys-expire"
|
||||
|
||||
return AppSettings{..}
|
||||
|
||||
makeClassy_ ''AppSettings
|
||||
|
||||
@ -855,6 +855,9 @@ takeWhileTime maxT = do
|
||||
let tDelta = now `diffUTCTime` sTime
|
||||
return $ tDelta < maxT
|
||||
|
||||
runPeekN :: forall o m n. (Integral n, Monad m) => n -> ConduitT () o m () -> m (ConduitT () o m (), [o])
|
||||
runPeekN n src = over (mapped . _1) unsealConduitT $ src $$+ peekN n
|
||||
|
||||
-----------------
|
||||
-- Alternative --
|
||||
-----------------
|
||||
|
||||
@ -233,6 +233,8 @@ makeLenses_ ''ExternalExamResult
|
||||
makeLenses_ ''Rating
|
||||
makeLenses_ ''Rating'
|
||||
|
||||
makeLenses_ ''FallbackPersonalisedSheetFilesKey
|
||||
|
||||
-- makeClassy_ ''Load
|
||||
|
||||
--------------------------
|
||||
|
||||
@ -119,6 +119,8 @@ extra-deps:
|
||||
- unordered-containers-0.2.11.0
|
||||
|
||||
- base64-bytestring-1.1.0.0
|
||||
- base32-0.2.0.0
|
||||
- ghc-byteorder-4.11.0.0.10
|
||||
|
||||
resolver: lts-15.12
|
||||
allow-newer: true
|
||||
|
||||
@ -346,6 +346,20 @@ packages:
|
||||
sha256: 9ade5b5911df97c37b249b84f123297049f19578cae171c647bf47683633427c
|
||||
original:
|
||||
hackage: base64-bytestring-1.1.0.0
|
||||
- completed:
|
||||
hackage: base32-0.2.0.0@sha256:459f0ba6412d58adf1d6ab68d5dc68afddc9f65c69ad564c0a9643d5d8a7e96e,2608
|
||||
pantry-tree:
|
||||
size: 1935
|
||||
sha256: 10c0a5a0a1d4c40b41f0190cf80b114fb527caf7458feec819d87ccfe41317cb
|
||||
original:
|
||||
hackage: base32-0.2.0.0
|
||||
- completed:
|
||||
hackage: ghc-byteorder-4.11.0.0.10@sha256:5ee4a907279bfec27b0f9de7b8fba4cecfd34395a0235a7784494de70ad4e98f,1535
|
||||
pantry-tree:
|
||||
size: 169
|
||||
sha256: 54a4636f72c3b9eff7f081714cb1a7b809fc1f3b2e239caaf0d65d79aa9cb56f
|
||||
original:
|
||||
hackage: ghc-byteorder-4.11.0.0.10
|
||||
snapshots:
|
||||
- completed:
|
||||
size: 494635
|
||||
|
||||
@ -579,6 +579,7 @@ fillDb = do
|
||||
, sheetAutoDistribute = False
|
||||
, sheetAnonymousCorrection = True
|
||||
, sheetRequireExamRegistration = Nothing
|
||||
, sheetAllowNonPersonalisedSubmission = True
|
||||
}
|
||||
insert_ $ SheetEdit gkleen now adhoc
|
||||
feste <- insert Sheet
|
||||
@ -597,6 +598,7 @@ fillDb = do
|
||||
, sheetAutoDistribute = False
|
||||
, sheetAnonymousCorrection = True
|
||||
, sheetRequireExamRegistration = Nothing
|
||||
, sheetAllowNonPersonalisedSubmission = True
|
||||
}
|
||||
insert_ $ SheetEdit gkleen now feste
|
||||
keine <- insert Sheet
|
||||
@ -615,6 +617,7 @@ fillDb = do
|
||||
, sheetAutoDistribute = False
|
||||
, sheetAnonymousCorrection = True
|
||||
, sheetRequireExamRegistration = Nothing
|
||||
, sheetAllowNonPersonalisedSubmission = True
|
||||
}
|
||||
insert_ $ SheetEdit gkleen now keine
|
||||
void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf Nothing CourseParticipantActive)
|
||||
@ -827,6 +830,7 @@ fillDb = do
|
||||
, sheetAutoDistribute = True
|
||||
, sheetAnonymousCorrection = True
|
||||
, sheetRequireExamRegistration = Nothing
|
||||
, sheetAllowNonPersonalisedSubmission = True
|
||||
}
|
||||
void . insert $ SheetEdit jost now shId
|
||||
when (submissionModeCorrector sheetSubmissionMode) $
|
||||
@ -1062,6 +1066,7 @@ fillDb = do
|
||||
, sheetAutoDistribute = False
|
||||
, sheetAnonymousCorrection = True
|
||||
, sheetRequireExamRegistration = Nothing
|
||||
, sheetAllowNonPersonalisedSubmission = True
|
||||
}
|
||||
manyUsers' <- shuffleM $ take 1024 manyUsers
|
||||
groupSizes <- getRandomRs (1, 3)
|
||||
|
||||
@ -32,6 +32,10 @@ import Data.Scientific
|
||||
import Utils.Lens hiding (elements)
|
||||
|
||||
import qualified Data.Char as Char
|
||||
import Data.Word.Word24
|
||||
|
||||
import qualified Data.Binary as Binary
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
|
||||
|
||||
instance (Arbitrary a, MonoFoldable a) => Arbitrary (NonNull a) where
|
||||
@ -280,6 +284,9 @@ instance Arbitrary CsvPreset where
|
||||
instance Arbitrary Sex where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance Arbitrary Word24 where
|
||||
arbitrary = arbitraryBoundedRandom
|
||||
|
||||
|
||||
|
||||
spec :: Spec
|
||||
@ -371,6 +378,8 @@ spec = do
|
||||
[ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @CsvPreset)
|
||||
[ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, pathPieceLaws ]
|
||||
lawsCheckHspec (Proxy @Word24)
|
||||
[ persistFieldLaws, jsonLaws, binaryLaws ]
|
||||
|
||||
describe "TermIdentifier" $ do
|
||||
it "has compatible encoding/decoding to/from Text" . property $
|
||||
@ -405,6 +414,23 @@ spec = do
|
||||
describe "CsvOptions" $
|
||||
it "json-decodes from empty object" . example $
|
||||
Aeson.parseMaybe Aeson.parseJSON (Aeson.object []) `shouldBe` Just (def :: CsvOptions)
|
||||
describe "Word24" $ do
|
||||
it "encodes to the expected length" . property $
|
||||
\w -> olength (Binary.encode (w :: Word24)) == 3
|
||||
it "encodes some examples correctly" $ do
|
||||
let decode' inp = case Binary.decodeOrFail inp of
|
||||
Right (unc, _, res)
|
||||
| null unc -> Just res
|
||||
_other
|
||||
-> Nothing
|
||||
encEx w str = example $ do
|
||||
Binary.encode (w :: Word24) `shouldBe` LBS.pack str
|
||||
decode' (LBS.pack str) `shouldBe` Just w
|
||||
encEx 1 [0, 0, 1]
|
||||
encEx 256 [0, 1, 0]
|
||||
encEx 65536 [1, 0, 0]
|
||||
encEx 65537 [1, 0, 1]
|
||||
encEx 197121 [3, 2, 1]
|
||||
|
||||
termExample :: (TermIdentifier, Text) -> Expectation
|
||||
termExample (term, encoded) = example $ do
|
||||
|
||||
@ -65,6 +65,7 @@ instance Arbitrary Sheet where
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> return Nothing
|
||||
<*> arbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary Tutorial where
|
||||
|
||||
@ -12,6 +12,11 @@ import Data.Binary.Put
|
||||
|
||||
binaryLaws :: forall a. (Arbitrary a, Binary a, Eq a, Show a) => Proxy a -> Laws
|
||||
binaryLaws _ = Laws "Binary"
|
||||
[ ("Partial Isomorphism", property $ \(a :: a) -> decode (encode a) == Just a)
|
||||
, ("Valid list encoding", property $ \(as :: [a]) -> runPut (putList as) == runPut (put as))
|
||||
[ ("Partial Isomorphism", property $ \(a :: a) -> decode' (encode a) === Just a)
|
||||
, ("Valid list encoding", property $ \(as :: [a]) -> runPut (putList as) === runPut (put as))
|
||||
]
|
||||
where decode' inp = case decodeOrFail inp of
|
||||
Right (unc, _, res)
|
||||
| null unc -> Just res
|
||||
_other
|
||||
-> Nothing
|
||||
|
||||
Loading…
Reference in New Issue
Block a user