From 05389fc27e8ac3b1e9f70d17c2f69bb07ce77ae2 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 15 May 2019 21:58:27 +0200 Subject: [PATCH 01/13] Splitting Model.Types into three parts --- package.yaml | 2 +- src/Handler/Corrections.hs | 2 +- src/Model/Types.hs | 953 +----------------------------------- src/Model/Types/DateTime.hs | 158 ++++++ src/Model/Types/Misc.hs | 532 ++++++++++++++++++++ src/Model/Types/Sheet.hs | 338 +++++++++++++ 6 files changed, 1042 insertions(+), 943 deletions(-) create mode 100644 src/Model/Types/DateTime.hs create mode 100644 src/Model/Types/Misc.hs create mode 100644 src/Model/Types/Sheet.hs diff --git a/package.yaml b/package.yaml index d0fc06ae8..098fb0bec 100644 --- a/package.yaml +++ b/package.yaml @@ -185,7 +185,7 @@ ghc-options: - -fno-warn-unrecognised-pragmas - -fno-warn-partial-type-signatures - -fno-max-relevant-binds - - -j2 + - -j3 when: - condition: flag(pedantic) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index d32195c58..4a18d3b79 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -531,7 +531,7 @@ postCorrectionsR = do optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses psValidator = def - & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information + & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information & restrictSorting (\name _ -> name /= "corrector") & defaultSorting [SortAscBy "israted", SortDescBy "ratingTime", SortAscBy "assignedtime" ] -- & defaultFilter (Map.fromList [("israted",[toPathPiece False])]) -- DEPENDS ON ISSUE #371 UNCOMMENT THEN diff --git a/src/Model/Types.hs b/src/Model/Types.hs index aa1c91037..b812d529c 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -3,8 +3,13 @@ #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text) + + module Model.Types ( module Model.Types + , module Model.Types.Sheet + , module Model.Types.DateTime + , module Model.Types.Misc , module Numeric.Natural , module Mail , module Utils.DateTime @@ -12,86 +17,31 @@ module Model.Types ) where import ClassyPrelude -import Utils -import Control.Lens hiding (universe) -import Utils.Lens.TH - -import Data.Set (Set) -import qualified Data.Set as Set -import qualified Data.Map as Map -import Data.Fixed -import Data.Monoid (Sum(..)) -import Data.Maybe (fromJust) -import Data.Universe -import Data.Universe.Helpers -import Data.Universe.TH import Data.UUID.Types (UUID) import qualified Data.UUID.Types as UUID - import Data.NonNull.Instances () -import Data.Default - -import Text.Read (readMaybe) - -import Database.Persist.TH hiding (derivePersistFieldJSON) -import Model.Types.JSON -import Database.Persist.Class -import Database.Persist.Sql - -import Web.HttpApiData -import Web.PathPieces - -import Text.Blaze (Markup) import Data.Text (Text) import qualified Data.Text as Text -import qualified Data.Text.Lens as Text - -import qualified Data.HashMap.Strict as HashMap - import Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI import Data.CaseInsensitive.Instances () -import Yesod.Core.Dispatch (PathPiece(..)) -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Types as Aeson -import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withText, withObject, Value()) -import Data.Aeson.Types (toJSONKeyText) -import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..), mkToJSON, mkParseJSON) - -import GHC.Generics (Generic) -import Generics.Deriving.Monoid (memptydefault, mappenddefault) -import Data.Typeable (Typeable) - import Data.Universe.Instances.Reverse () +import Yesod.Core.Dispatch (PathPiece(..)) import qualified Yesod.Auth.Util.PasswordStore as PWStore +import Web.PathPieces 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 Data.Data (Data) -import Model.Types.Wordlist -import Data.Text.Metrics (damerauLevenshtein) - -import Data.Binary (Binary) -import qualified Data.Binary as Binary - -import Time.Types (WeekDay(..)) -import Data.Time.LocalTime (LocalTime, TimeOfDay) - -import Data.Semigroup (Min(..)) -import Control.Monad.Trans.Writer (execWriter) -import Control.Monad.Writer.Class (MonadWriter(..)) +import Model.Types.Sheet +import Model.Types.DateTime +import Model.Types.Misc +---- +-- Just bringing together the different Model.Types submodules. instance PathPiece UUID where fromPathPiece = UUID.fromString . unpack @@ -102,885 +52,6 @@ instance {-# OVERLAPS #-} PathMultiPiece FilePath where toPathMultiPiece = Text.splitOn "/" . pack -type Count = Sum Integer -type Points = Centi - -toPoints :: Integral a => a -> Points -- deprecated -toPoints = fromIntegral - -pToI :: Points -> Integer -- deprecated -pToI = fromPoints - -fromPoints :: Integral a => Points -> a -- deprecated -fromPoints = round - -instance DisplayAble Points - -instance DisplayAble a => DisplayAble (Sum a) where - display (Sum x) = display x - -data SheetGrading - = Points { maxPoints :: Points } - | PassPoints { maxPoints, passingPoints :: Points } - | PassBinary -- non-zero means passed - deriving (Eq, Read, Show, Generic) - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece - , fieldLabelModifier = intercalate "-" . map toLower . dropEnd 1 . splitCamel - , sumEncoding = TaggedObject "type" "data" - } ''SheetGrading -derivePersistFieldJSON ''SheetGrading - -makeLenses_ ''SheetGrading - -_passingBound :: Fold SheetGrading (Either () Points) -_passingBound = folding passPts - where - passPts :: SheetGrading -> Maybe (Either () Points) - passPts (Points{}) = Nothing - passPts (PassPoints{passingPoints}) = Just $ Right passingPoints - passPts (PassBinary) = Just $ Left () - -gradingPassed :: SheetGrading -> Points -> Maybe Bool -gradingPassed gr pts = either pBinary pPoints <$> gr ^? _passingBound - where pBinary _ = pts /= 0 - pPoints b = pts >= b - - -data SheetGradeSummary = SheetGradeSummary - { numSheets :: Count -- Total number of sheets, includes all - , numSheetsPasses :: Count -- Number of sheets required to pass FKA: numGradePasses - , numSheetsPoints :: Count -- Number of sheets having points FKA: sumGradePointsd - , sumSheetsPoints :: Sum Points -- Total of all points in all sheets - -- Marking dependend - , numMarked :: Count -- Number of already marked sheets - , numMarkedPasses :: Count -- Number of already marked sheets with passes - , numMarkedPoints :: Count -- Number of already marked sheets with points - , sumMarkedPoints :: Sum Points -- Achieveable points within marked sheets - -- - , achievedPasses :: Count -- Achieved passes (within marked sheets) - , achievedPoints :: Sum Points -- Achieved points (within marked sheets) - } deriving (Generic, Read, Show, Eq) - -instance Monoid SheetGradeSummary where - mempty = memptydefault - mappend = mappenddefault - -instance Semigroup SheetGradeSummary where - (<>) = mappend -- TODO: remove for GHC > 8.4.x - -makeLenses_ ''SheetGradeSummary - -sheetGradeSum :: SheetGrading -> Maybe Points -> SheetGradeSummary -sheetGradeSum gr Nothing = mempty - { numSheets = 1 - , numSheetsPasses = bool mempty 1 $ has _passingBound gr - , numSheetsPoints = bool mempty 1 $ has _maxPoints gr - , sumSheetsPoints = maybe mempty Sum $ gr ^? _maxPoints - } -sheetGradeSum gr (Just p) = - let unmarked@SheetGradeSummary{..} = sheetGradeSum gr Nothing - in unmarked - { numMarked = numSheets - , numMarkedPasses = numSheetsPasses - , numMarkedPoints = numSheetsPoints - , sumMarkedPoints = sumSheetsPoints - , achievedPasses = fromMaybe mempty $ bool 0 1 <$> gradingPassed gr p - , achievedPoints = bool mempty (Sum p) $ has _maxPoints gr - } - - -data SheetType - = NotGraded - | Normal { grading :: SheetGrading } - | Bonus { grading :: SheetGrading } - | Informational { grading :: SheetGrading } - deriving (Eq, Read, Show, Generic) - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece - , fieldLabelModifier = camelToPathPiece - , sumEncoding = TaggedObject "type" "data" - } ''SheetType -derivePersistFieldJSON ''SheetType - -data SheetTypeSummary = SheetTypeSummary - { normalSummary - , bonusSummary - , informationalSummary :: SheetGradeSummary - , numNotGraded :: Count - } deriving (Generic, Read, Show, Eq) - -instance Monoid SheetTypeSummary where - mempty = memptydefault - mappend = mappenddefault - -instance Semigroup SheetTypeSummary where - (<>) = mappend -- TODO: remove for GHC > 8.4.x - -makeLenses_ ''SheetTypeSummary - -sheetTypeSum :: SheetType -> Maybe Points -> SheetTypeSummary -sheetTypeSum Bonus{..} mps = mempty { bonusSummary = sheetGradeSum grading mps } -sheetTypeSum Normal{..} mps = mempty { normalSummary = sheetGradeSum grading mps } -sheetTypeSum Informational{..} mps = mempty { informationalSummary = sheetGradeSum grading mps } -sheetTypeSum NotGraded _ = mempty { numNotGraded = Sum 1 } - -data SheetGroup - = Arbitrary { maxParticipants :: Natural } - | RegisteredGroups - | NoGroups - deriving (Show, Read, Eq, Generic) -deriveJSON defaultOptions ''SheetGroup -derivePersistFieldJSON ''SheetGroup - -makeLenses_ ''SheetGroup - -data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking - deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) -derivePersistField "SheetFileType" - -instance Universe SheetFileType where universe = universeDef -instance Finite SheetFileType - -instance PathPiece SheetFileType where - toPathPiece SheetExercise = "file" - toPathPiece SheetHint = "hint" - toPathPiece SheetSolution = "solution" - toPathPiece SheetMarking = "marking" - fromPathPiece = finiteFromPathPiece - -sheetFile2markup :: SheetFileType -> Markup -sheetFile2markup SheetExercise = iconQuestion -sheetFile2markup SheetHint = iconHint -sheetFile2markup SheetSolution = iconSolution -sheetFile2markup SheetMarking = iconMarking - --- $(deriveSimpleWith ''DisplayAble 'display (drop 17) ''SheetFileType) -instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instance in Foundation - display SheetExercise = "Aufgabenstellung" - display SheetHint = "Hinweise" - display SheetSolution = "Musterlösung" - display SheetMarking = "Korrekturhinweise" - --- partitionFileType' :: Ord a => [(SheetFileType,a)] -> Map SheetFileType (Set a) --- partitionFileType' = groupMap - -partitionFileType :: Ord a => [(SheetFileType,a)] -> SheetFileType -> Set a -partitionFileType fs t = Map.findWithDefault Set.empty t . Map.fromListWith Set.union $ map (over _2 Set.singleton) fs - -data SubmissionFileType = SubmissionOriginal | SubmissionCorrected - deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) - -instance Universe SubmissionFileType where universe = universeDef -instance Finite SubmissionFileType - -submissionFileTypeIsUpdate :: SubmissionFileType -> Bool -submissionFileTypeIsUpdate SubmissionOriginal = False -submissionFileTypeIsUpdate SubmissionCorrected = True - -isUpdateSubmissionFileType :: Bool -> SubmissionFileType -isUpdateSubmissionFileType False = SubmissionOriginal -isUpdateSubmissionFileType True = SubmissionCorrected - -instance PathPiece SubmissionFileType where - toPathPiece SubmissionOriginal = "original" - toPathPiece SubmissionCorrected = "corrected" - fromPathPiece = finiteFromPathPiece - -instance DisplayAble SubmissionFileType where - display SubmissionOriginal = "Abgabe" - display SubmissionCorrected = "Korrektur" - -{- -data DA = forall a . (DisplayAble a) => DA a - -instance DisplayAble DA where - display (DA x) = display x --} - - -data UploadMode = NoUpload | Upload { unpackZips :: Bool } - deriving (Show, Read, Eq, Ord, Generic) - -deriveFinite ''UploadMode - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece - , fieldLabelModifier = camelToPathPiece - , sumEncoding = TaggedObject "mode" "settings" - }''UploadMode -derivePersistFieldJSON ''UploadMode - -instance PathPiece UploadMode where - toPathPiece = \case - NoUpload -> "no-upload" - Upload True -> "unpack" - Upload False -> "no-unpack" - fromPathPiece = finiteFromPathPiece - -data SubmissionMode = SubmissionMode - { submissionModeCorrector :: Bool - , submissionModeUser :: Maybe UploadMode - } - deriving (Show, Read, Eq, Ord, Generic) - -deriveFinite ''SubmissionMode - -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 2 - } ''SubmissionMode -derivePersistFieldJSON ''SubmissionMode - -finitePathPiece ''SubmissionMode - [ "no-submissions" - , "no-upload" - , "no-unpack" - , "unpack" - , "correctors" - , "correctors+no-upload" - , "correctors+no-unpack" - , "correctors+unpack" - ] - -data SubmissionModeDescr = SubmissionModeNone - | SubmissionModeCorrector - | SubmissionModeUser - | SubmissionModeBoth - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) -instance Universe SubmissionModeDescr -instance Finite SubmissionModeDescr - -finitePathPiece ''SubmissionModeDescr - [ "no-submissions" - , "correctors" - , "users" - , "correctors+users" - ] - -classifySubmissionMode :: SubmissionMode -> SubmissionModeDescr -classifySubmissionMode (SubmissionMode False Nothing ) = SubmissionModeNone -classifySubmissionMode (SubmissionMode True Nothing ) = SubmissionModeCorrector -classifySubmissionMode (SubmissionMode False (Just _)) = SubmissionModeUser -classifySubmissionMode (SubmissionMode True (Just _)) = SubmissionModeBoth - - -data ExamStatus = Attended | NoShow | Voided - deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) -derivePersistField "ExamStatus" - --- | Specify a corrector's workload -data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rational } - = Load { byTutorial :: Maybe Bool -- ^ @Just@ all from Tutorial, @True@ if counting towards overall workload - , byProportion :: Rational -- ^ workload proportion of all submission not assigned to tutorial leaders - } - deriving (Show, Read, Eq, Ord, Generic) - -deriveJSON defaultOptions ''Load -derivePersistFieldJSON ''Load - -instance Hashable Load - -instance Semigroup Load where - (Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop') - where - byTut'' - | Nothing <- byTut = byTut' - | Nothing <- byTut' = byTut - | Just a <- byTut - , Just b <- byTut' = Just $ a || b - -instance Monoid Load where - mempty = Load Nothing 0 - mappend = (<>) - -{- Use (is _ByTutorial) instead of this unneeded definition: - isByTutorial :: Load -> Bool - isByTutorial (ByTutorial {}) = True - isByTutorial _ = False --} - -data Season = Summer | Winter - deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable) - -instance Binary Season - -seasonToChar :: Season -> Char -seasonToChar Summer = 'S' -seasonToChar Winter = 'W' - -seasonFromChar :: Char -> Either Text Season -seasonFromChar c - | c ~= 'S' = Right Summer - | c ~= 'W' = Right Winter - | otherwise = Left $ "Invalid season character: ‘" <> tshow c <> "’" - where - (~=) = (==) `on` CI.mk - -instance DisplayAble Season - -data TermIdentifier = TermIdentifier - { year :: Integer -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar' - , season :: Season - } deriving (Show, Read, Eq, Ord, Generic, Typeable) - -instance Binary TermIdentifier - -instance Enum TermIdentifier where - -- ^ Do not use for conversion – Enumeration only - toEnum int = let (toInteger -> year, toEnum -> season) = int `divMod` 2 in TermIdentifier{..} - fromEnum TermIdentifier{..} = fromInteger year * 2 + fromEnum season - --- Conversion TermId <-> TermIdentifier:: --- from_TermId_to_TermIdentifier = unTermKey --- from_TermIdentifier_to_TermId = TermKey - -shortened :: Iso' Integer Integer -shortened = iso shorten expand - where - century = ($currentYear `div` 100) * 100 - expand year - | 0 <= year - , year < 100 = let - options = [ expanded | offset <- [-1, 0, 1] - , let century' = century + offset * 100 - expanded = century' + year - , $currentYear - 50 <= expanded - , expanded < $currentYear + 50 - ] - in case options of - [unique] -> unique - failed -> error $ "Could not expand year " ++ show year ++ ": " ++ show failed - | otherwise = year - shorten year - | $currentYear - 50 <= year - , year < $currentYear + 50 = year `mod` 100 - | otherwise = year - -termToText :: TermIdentifier -> Text -termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show (year ^. shortened) - --- also see Hander.Utils.tidFromText -termFromText :: Text -> Either Text TermIdentifier -termFromText t - | (s:ys) <- Text.unpack t - , Just (review shortened -> year) <- readMaybe ys - , Right season <- seasonFromChar s - = Right TermIdentifier{..} - | otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”" -- TODO: Could be improved, I.e. say "W"/"S" from Number - -termToRational :: TermIdentifier -> Rational -termToRational TermIdentifier{..} = fromInteger year + seasonOffset - where - seasonOffset - | Summer <- season = 0 - | Winter <- season = 0.5 - -termFromRational :: Rational -> TermIdentifier -termFromRational n = TermIdentifier{..} - where - year = floor n - remainder = n - (fromInteger $ floor n) - season - | remainder == 0 = Summer - | otherwise = Winter - -instance PersistField TermIdentifier where - toPersistValue = PersistRational . termToRational - fromPersistValue (PersistRational t) = Right $ termFromRational t - fromPersistValue x = Left $ "Expected TermIdentifier, received: " <> tshow x - -instance PersistFieldSql TermIdentifier where - sqlType _ = SqlNumeric 5 1 - -instance ToHttpApiData TermIdentifier where - toUrlPiece = termToText - -instance FromHttpApiData TermIdentifier where - parseUrlPiece = termFromText - -instance PathPiece TermIdentifier where - fromPathPiece = either (const Nothing) Just . termFromText - toPathPiece = termToText - -instance ToJSON TermIdentifier where - toJSON = Aeson.String . termToText - -instance FromJSON TermIdentifier where - parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText - -{- Must be defined in a later module: - termField :: Field (HandlerT UniWorX IO) TermIdentifier - termField = checkMMap (return . termFromText) termToText textField - See Handler.Utils.Form.termsField and termActiveField --} - - -withinTerm :: Day -> TermIdentifier -> Bool -time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100 - where - timeYear = fst3 $ toGregorian time - termYear = year term - - -data StudyFieldType = FieldPrimary | FieldSecondary - deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic) -derivePersistField "StudyFieldType" - -instance PersistField UUID where - toPersistValue = PersistDbSpecific . UUID.toASCIIBytes - fromPersistValue (PersistText t) = maybe (Left "Failed to parse UUID") Right $ UUID.fromText t - fromPersistValue (PersistByteString bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs - fromPersistValue (PersistDbSpecific bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs - fromPersistValue x = Left $ "Expected UUID, received: " <> tshow x - -instance PersistFieldSql UUID where - sqlType _ = SqlOther "uuid" - -instance DisplayAble StudyFieldType - -data Theme - = ThemeDefault - | ThemeLavender - | ThemeNeutralBlue - | ThemeAberdeenReds - | ThemeMossGreen - | ThemeSkyLove - deriving (Eq, Ord, Bounded, Enum, Show, Read, Generic) - -deriveJSON defaultOptions - { constructorTagModifier = fromJust . stripPrefix "Theme" - } ''Theme - -instance Universe Theme where universe = universeDef -instance Finite Theme - -nullaryPathPiece ''Theme (camelToPathPiece' 1) - -$(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user - -derivePersistField "Theme" - - -newtype ZIPArchiveName obj = ZIPArchiveName { unZIPArchiveName :: obj } - deriving (Show, Read, Eq, Ord, Generic, Typeable) - -instance PathPiece obj => PathPiece (ZIPArchiveName obj) where - fromPathPiece = fmap ZIPArchiveName . fromPathPiece <=< (stripSuffix `on` CI.foldCase) ".zip" - toPathPiece = (<> ".zip") . toPathPiece . unZIPArchiveName - - -data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) - -deriveJSON defaultOptions - { constructorTagModifier = fromJust . stripPrefix "Corrector" - } ''CorrectorState - -instance Universe CorrectorState -instance Finite CorrectorState - -instance Hashable CorrectorState - -nullaryPathPiece ''CorrectorState (camelToPathPiece' 1) - -derivePersistField "CorrectorState" - - -data AuthenticationMode = AuthLDAP - | AuthPWHash { authPWHash :: Text } - deriving (Eq, Ord, Read, Show, Generic) - -deriveJSON defaultOptions - { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel - , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel - , sumEncoding = UntaggedValue - } ''AuthenticationMode - -derivePersistFieldJSON ''AuthenticationMode - - -derivePersistFieldJSON ''Value - - --- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@ --- --- Could maybe be replaced with `Structure Notification` in the long term -data NotificationTrigger = NTSubmissionRatedGraded - | NTSubmissionRated - | NTSheetActive - | NTSheetSoonInactive - | NTSheetInactive - | NTCorrectionsAssigned - | NTCorrectionsNotDistributed - | NTUserRightsUpdate - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - -instance Universe NotificationTrigger -instance Finite NotificationTrigger - -instance Hashable NotificationTrigger - -deriveJSON defaultOptions - { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel - } ''NotificationTrigger - -instance ToJSONKey NotificationTrigger where - toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t - -instance FromJSONKey NotificationTrigger where - fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String - - -newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool } - deriving (Generic, Typeable) - deriving newtype (Eq, Ord, Read, Show) - -instance Default NotificationSettings where - def = NotificationSettings $ \case - NTSubmissionRatedGraded -> True - NTSubmissionRated -> False - NTSheetActive -> True - NTSheetSoonInactive -> False - NTSheetInactive -> True - NTCorrectionsAssigned -> True - NTCorrectionsNotDistributed -> True - NTUserRightsUpdate -> True - -instance ToJSON NotificationSettings where - toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF - -instance FromJSON NotificationSettings where - parseJSON = withObject "NotificationSettings" $ \o -> do - o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap NotificationTrigger Bool) - return . NotificationSettings $ \n -> case HashMap.lookup n o' of - Nothing -> notificationAllowed def n - Just b -> b - -derivePersistFieldJSON ''NotificationSettings - - -instance ToBackendKey SqlBackend record => Hashable (Key record) where - hashWithSalt s key = s `hashWithSalt` fromSqlKey key - -derivePersistFieldJSON ''MailLanguages - - -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) - -instance FromJSON Pseudonym where - parseJSON v@(Aeson.Number _) = do - w <- parseJSON v :: Aeson.Parser Word32 - if - | 0 <= w - , w <= fromIntegral (maxBound :: Pseudonym) - -> return $ fromIntegral w - | otherwise - -> fail "Pseudonym out auf range" - parseJSON (Aeson.String t) - = case t ^? _PseudonymText of - Just p -> return p - Nothing -> fail "Could not parse pseudonym" - parseJSON v = flip (Aeson.withArray "Pseudonym") v $ \ws -> do - ws' <- toList . map CI.mk <$> mapM parseJSON ws - case ws' ^? _PseudonymWords of - Just p -> return p - Nothing -> fail "Could not parse pseudonym words" - -instance ToJSON Pseudonym where - toJSON = toJSON . (review _PseudonymWords :: Pseudonym -> [PseudonymWord]) - -pseudonymWordlist :: [PseudonymWord] -pseudonymCharacters :: Set (CI Char) -(pseudonymWordlist, pseudonymCharacters) = $(wordlist "config/wordlist.txt") - -_PseudonymWords :: Prism' [PseudonymWord] Pseudonym -_PseudonymWords = prism' pToWords pFromWords - where - pFromWords :: [PseudonymWord] -> Maybe Pseudonym - pFromWords [w1, w2] - | Just i1 <- elemIndex w1 pseudonymWordlist - , Just i2 <- elemIndex w2 pseudonymWordlist - , i1 <= maxWord, i2 <= maxWord - = Just . Pseudonym $ shiftL (fromIntegral i1) 12 .|. fromIntegral i2 - pFromWords _ = Nothing - - pToWords :: Pseudonym -> [PseudonymWord] - pToWords (Pseudonym p) - = [ genericIndex pseudonymWordlist $ shiftR p 12 .&. maxWord - , genericIndex pseudonymWordlist $ p .&. maxWord - ] - - maxWord :: Num a => a - maxWord = 0b111111111111 - -_PseudonymText :: Prism' Text Pseudonym -_PseudonymText = prism' tToWords tFromWords . _PseudonymWords - where - tFromWords :: Text -> Maybe [PseudonymWord] - tFromWords input - | [result] <- input ^.. pseudonymFragments - = Just result - | otherwise - = Nothing - - tToWords :: [PseudonymWord] -> Text - tToWords = Text.unwords . map CI.original - -pseudonymWords :: Fold Text PseudonymWord -pseudonymWords = folding - $ \(CI.mk -> input) -> map (view _2) . fromMaybe [] . listToMaybe . groupBy ((==) `on` view _1) . sortBy (comparing $ view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist - where - distance = damerauLevenshtein `on` CI.foldedCase - -- | Arbitrary cutoff point, for reference: ispell cuts off at 1 - distanceCutoff = 2 - -pseudonymFragments :: Fold Text [PseudonymWord] -pseudonymFragments = folding - $ mapM (toListOf pseudonymWords) . (\l -> guard (length l == 2) *> l) . filter (not . null) . Text.split (\(CI.mk -> c) -> not $ Set.member c pseudonymCharacters) - - -data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer - = AuthAdmin - | AuthLecturer - | AuthCorrector - | AuthTutor - | AuthCourseRegistered - | AuthTutorialRegistered - | AuthParticipant - | AuthTime - | AuthMaterials - | AuthOwner - | AuthRated - | AuthUserSubmissions - | AuthCorrectorSubmissions - | AuthCapacity - | AuthRegisterGroup - | AuthEmpty - | AuthSelf - | AuthAuthentication - | AuthNoEscalation - | AuthRead - | AuthWrite - | AuthToken - | AuthDeprecated - | AuthDevelopment - | AuthFree - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) - -instance Universe AuthTag -instance Finite AuthTag -instance Hashable AuthTag - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 - } ''AuthTag - -nullaryPathPiece ''AuthTag (camelToPathPiece' 1) - -instance ToJSONKey AuthTag where - toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t - -instance FromJSONKey AuthTag where - fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String - -instance Binary AuthTag - - -newtype AuthTagActive = AuthTagActive { authTagIsActive :: AuthTag -> Bool } - deriving (Read, Show, Generic) - deriving newtype (Eq, Ord) - -instance Default AuthTagActive where - def = AuthTagActive $ \case - AuthAdmin -> False - _ -> True - -instance ToJSON AuthTagActive where - toJSON v = toJSON . HashMap.fromList $ map (id &&& authTagIsActive v) universeF - -instance FromJSON AuthTagActive where - parseJSON = withObject "AuthTagActive" $ \o -> do - o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap AuthTag Bool) - return . AuthTagActive $ \n -> case HashMap.lookup n o' of - Nothing -> authTagIsActive def n - Just b -> b - -derivePersistFieldJSON ''AuthTagActive - - -data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a } - deriving (Eq, Ord, Read, Show, Generic, Typeable) - -instance Hashable a => Hashable (PredLiteral a) -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 - , sumEncoding = TaggedObject "val" "var" - } ''PredLiteral - -instance PathPiece a => PathPiece (PredLiteral a) where - toPathPiece PLVariable{..} = toPathPiece plVar - toPathPiece PLNegated{..} = "¬" <> toPathPiece plVar - - fromPathPiece t = PLVariable <$> fromPathPiece t - <|> PLNegated <$> (Text.stripPrefix "¬" t >>= fromPathPiece) - -instance Binary a => Binary (PredLiteral a) - - -newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) } - deriving (Eq, Ord, Read, Show, Generic, Typeable) - deriving newtype (Semigroup, Monoid) - -$(return []) - -instance ToJSON a => ToJSON (PredDNF a) where - toJSON = $(mkToJSON predNFAesonOptions ''PredDNF) -instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where - parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF) - -instance (Ord a, Binary a) => Binary (PredDNF a) where - get = PredDNF <$> Binary.get - put = Binary.put . dnfTerms - -type AuthLiteral = PredLiteral AuthTag - -type AuthDNF = PredDNF AuthTag - - -data LecturerType = CourseLecturer | CourseAssistant - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - -instance Universe LecturerType -instance Finite LecturerType - -nullaryPathPiece ''LecturerType $ camelToPathPiece' 1 -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 - } ''LecturerType -derivePersistFieldJSON ''LecturerType - -instance Hashable LecturerType - - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece - } ''WeekDay - -data OccurenceSchedule = ScheduleWeekly - { scheduleDayOfWeek :: WeekDay - , scheduleStart :: TimeOfDay - , scheduleEnd :: TimeOfDay - } - deriving (Eq, Ord, Read, Show, Generic, Typeable) - -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 - , constructorTagModifier = camelToPathPiece' 1 - , tagSingleConstructors = True - , sumEncoding = TaggedObject "repeat" "schedule" - } ''OccurenceSchedule - -data OccurenceException = ExceptOccur - { exceptDay :: Day - , exceptStart :: TimeOfDay - , exceptEnd :: TimeOfDay - } - | ExceptNoOccur - { exceptTime :: LocalTime - } - deriving (Eq, Ord, Read, Show, Generic, Typeable) - -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 - , constructorTagModifier = camelToPathPiece' 1 - , sumEncoding = TaggedObject "exception" "for" - } ''OccurenceException - -data Occurences = Occurences - { occurencesScheduled :: Set OccurenceSchedule - , occurencesExceptions :: Set OccurenceException - } deriving (Eq, Ord, Read, Show, Generic, Typeable) - -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 - } ''Occurences -derivePersistFieldJSON ''Occurences - - -data HealthReport = HealthReport - { healthMatchingClusterConfig :: Bool - -- ^ Is the database-stored configuration we're running under still up to date? - , healthHTTPReachable :: Maybe Bool - -- ^ Can we reach a uni2work-instance with the same `ClusterId` under our configured `approot` via HTTP? - -- - -- Can be `Nothing` if we don't have a static configuration setting `appRoot` or if check is disabled in settings - , healthLDAPAdmins :: Maybe Rational - -- ^ Proportion of school admins that could be found in LDAP - -- - -- Is `Nothing` if LDAP is not configured or no users are school admins - , healthSMTPConnect :: Maybe Bool - -- ^ Can we connect to the SMTP server and say @NOOP@? - , healthWidgetMemcached :: Maybe Bool - -- ^ Can we store values in memcached and retrieve them via HTTP? - } deriving (Eq, Ord, Read, Show, Generic, Typeable) - -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 - , omitNothingFields = True - } ''HealthReport - --- | `HealthReport` classified (`classifyHealthReport`) by badness --- --- > a < b = a `worseThan` b --- --- Currently all consumers of this type check for @(== HealthSuccess)@; this --- needs to be adjusted on a case-by-case basis if new constructors are added -data HealthStatus = HealthFailure | HealthSuccess - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - -instance Universe HealthStatus -instance Finite HealthStatus - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 - } ''HealthStatus -nullaryPathPiece ''HealthStatus $ camelToPathPiece' 1 - -classifyHealthReport :: HealthReport -> HealthStatus --- ^ Classify `HealthReport` by badness -classifyHealthReport HealthReport{..} = getMin . execWriter $ do -- Construction with `Writer (Min HealthStatus) a` returns worst `HealthStatus` passed to `tell` at any point - unless healthMatchingClusterConfig . tell $ Min HealthFailure - unless (fromMaybe True healthHTTPReachable) . tell $ Min HealthFailure - unless (maybe True (> 0) healthLDAPAdmins) . tell $ Min HealthFailure - unless (fromMaybe True healthSMTPConnect) . tell $ Min HealthFailure - unless (fromMaybe True healthWidgetMemcached) . tell $ Min HealthFailure - - -- Type synonyms type Email = Text diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs new file mode 100644 index 000000000..05fe00594 --- /dev/null +++ b/src/Model/Types/DateTime.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving + , UndecidableInstances + #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text) + +module Model.Types.DateTime where + + +import ClassyPrelude +import GHC.Generics (Generic) +import Utils +import Control.Lens hiding (universe) +import Data.NonNull.Instances () +import Data.Typeable (Typeable) +import Data.Universe.Instances.Reverse () +import Data.Binary (Binary) + +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.CaseInsensitive as CI +import Data.CaseInsensitive.Instances () +import Text.Read (readMaybe) + +import Database.Persist.Class +import Database.Persist.Sql + +import Web.HttpApiData + +import Yesod.Core.Dispatch (PathPiece(..)) +import qualified Data.Aeson as Aeson +import Data.Aeson (FromJSON(..), ToJSON(..), withText) + + +---- +-- Terms, Seaons, anything loosely related to time + +data Season = Summer | Winter + deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable) + +instance Binary Season + +seasonToChar :: Season -> Char +seasonToChar Summer = 'S' +seasonToChar Winter = 'W' + +seasonFromChar :: Char -> Either Text Season +seasonFromChar c + | c ~= 'S' = Right Summer + | c ~= 'W' = Right Winter + | otherwise = Left $ "Invalid season character: ‘" <> tshow c <> "’" + where + (~=) = (==) `on` CI.mk + +instance DisplayAble Season + +data TermIdentifier = TermIdentifier + { year :: Integer -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar' + , season :: Season + } deriving (Show, Read, Eq, Ord, Generic, Typeable) + +instance Binary TermIdentifier + +instance Enum TermIdentifier where + -- ^ Do not use for conversion – Enumeration only + toEnum int = let (toInteger -> year, toEnum -> season) = int `divMod` 2 in TermIdentifier{..} + fromEnum TermIdentifier{..} = fromInteger year * 2 + fromEnum season + +-- Conversion TermId <-> TermIdentifier:: +-- from_TermId_to_TermIdentifier = unTermKey +-- from_TermIdentifier_to_TermId = TermKey + +shortened :: Iso' Integer Integer +shortened = iso shorten expand + where + century = ($currentYear `div` 100) * 100 + expand year + | 0 <= year + , year < 100 = let + options = [ expanded | offset <- [-1, 0, 1] + , let century' = century + offset * 100 + expanded = century' + year + , $currentYear - 50 <= expanded + , expanded < $currentYear + 50 + ] + in case options of + [unique] -> unique + failed -> error $ "Could not expand year " ++ show year ++ ": " ++ show failed + | otherwise = year + shorten year + | $currentYear - 50 <= year + , year < $currentYear + 50 = year `mod` 100 + | otherwise = year + +termToText :: TermIdentifier -> Text +termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show (year ^. shortened) + +-- also see Hander.Utils.tidFromText +termFromText :: Text -> Either Text TermIdentifier +termFromText t + | (s:ys) <- Text.unpack t + , Just (review shortened -> year) <- readMaybe ys + , Right season <- seasonFromChar s + = Right TermIdentifier{..} + | otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”" -- TODO: Could be improved, I.e. say "W"/"S" from Number + +termToRational :: TermIdentifier -> Rational +termToRational TermIdentifier{..} = fromInteger year + seasonOffset + where + seasonOffset + | Summer <- season = 0 + | Winter <- season = 0.5 + +termFromRational :: Rational -> TermIdentifier +termFromRational n = TermIdentifier{..} + where + year = floor n + remainder = n - (fromInteger $ floor n) + season + | remainder == 0 = Summer + | otherwise = Winter + +instance PersistField TermIdentifier where + toPersistValue = PersistRational . termToRational + fromPersistValue (PersistRational t) = Right $ termFromRational t + fromPersistValue x = Left $ "Expected TermIdentifier, received: " <> tshow x + +instance PersistFieldSql TermIdentifier where + sqlType _ = SqlNumeric 5 1 + +instance ToHttpApiData TermIdentifier where + toUrlPiece = termToText + +instance FromHttpApiData TermIdentifier where + parseUrlPiece = termFromText + +instance PathPiece TermIdentifier where + fromPathPiece = either (const Nothing) Just . termFromText + toPathPiece = termToText + +instance ToJSON TermIdentifier where + toJSON = Aeson.String . termToText + +instance FromJSON TermIdentifier where + parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText + +{- Must be defined in a later module: + termField :: Field (HandlerT UniWorX IO) TermIdentifier + termField = checkMMap (return . termFromText) termToText textField + See Handler.Utils.Form.termsField and termActiveField +-} + + +withinTerm :: Day -> TermIdentifier -> Bool +time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100 + where + timeYear = fst3 $ toGregorian time + termYear = year term + diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs new file mode 100644 index 000000000..226665e63 --- /dev/null +++ b/src/Model/Types/Misc.hs @@ -0,0 +1,532 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving + , UndecidableInstances + #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text) + +module Model.Types.Misc where + + +import ClassyPrelude +import Utils +import Control.Lens hiding (universe) + +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Maybe (fromJust) +import Data.Universe +import Data.Universe.Helpers +import Data.UUID.Types (UUID) +import qualified Data.UUID.Types as UUID + +import Data.NonNull.Instances () + +import Data.Default + +import Database.Persist.TH hiding (derivePersistFieldJSON) +import Model.Types.JSON +import Database.Persist.Class +import Database.Persist.Sql + +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Lens as Text + +import qualified Data.HashMap.Strict as HashMap + +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import Data.CaseInsensitive.Instances () + +import Yesod.Core.Dispatch (PathPiece(..)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withObject, Value()) +import Data.Aeson.Types (toJSONKeyText) +import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..), mkToJSON, mkParseJSON) + +import GHC.Generics (Generic) +import Data.Typeable (Typeable) + +import Data.Universe.Instances.Reverse () + +import Mail (MailLanguages(..)) + +import Data.Word.Word24 (Word24) +import Data.Bits +import Data.Ix +import Data.List (genericIndex, elemIndex) +import System.Random (Random(..)) +import Data.Data (Data) + +import Model.Types.Wordlist +import Data.Text.Metrics (damerauLevenshtein) + +import Data.Binary (Binary) +import qualified Data.Binary as Binary + +import Time.Types (WeekDay(..)) +import Data.Time.LocalTime (LocalTime, TimeOfDay) + +import Data.Semigroup (Min(..)) +import Control.Monad.Trans.Writer (execWriter) +import Control.Monad.Writer.Class (MonadWriter(..)) + + + + +data StudyFieldType = FieldPrimary | FieldSecondary + deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic) +derivePersistField "StudyFieldType" + +instance PersistField UUID where + toPersistValue = PersistDbSpecific . UUID.toASCIIBytes + fromPersistValue (PersistText t) = maybe (Left "Failed to parse UUID") Right $ UUID.fromText t + fromPersistValue (PersistByteString bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs + fromPersistValue (PersistDbSpecific bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs + fromPersistValue x = Left $ "Expected UUID, received: " <> tshow x + +instance PersistFieldSql UUID where + sqlType _ = SqlOther "uuid" + +instance DisplayAble StudyFieldType + +data Theme + = ThemeDefault + | ThemeLavender + | ThemeNeutralBlue + | ThemeAberdeenReds + | ThemeMossGreen + | ThemeSkyLove + deriving (Eq, Ord, Bounded, Enum, Show, Read, Generic) + +deriveJSON defaultOptions + { constructorTagModifier = fromJust . stripPrefix "Theme" + } ''Theme + +instance Universe Theme where universe = universeDef +instance Finite Theme + +nullaryPathPiece ''Theme (camelToPathPiece' 1) + +$(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user + +derivePersistField "Theme" + + +newtype ZIPArchiveName obj = ZIPArchiveName { unZIPArchiveName :: obj } + deriving (Show, Read, Eq, Ord, Generic, Typeable) + +instance PathPiece obj => PathPiece (ZIPArchiveName obj) where + fromPathPiece = fmap ZIPArchiveName . fromPathPiece <=< (stripSuffix `on` CI.foldCase) ".zip" + toPathPiece = (<> ".zip") . toPathPiece . unZIPArchiveName + + +data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) + +deriveJSON defaultOptions + { constructorTagModifier = fromJust . stripPrefix "Corrector" + } ''CorrectorState + +instance Universe CorrectorState +instance Finite CorrectorState + +instance Hashable CorrectorState + +nullaryPathPiece ''CorrectorState (camelToPathPiece' 1) + +derivePersistField "CorrectorState" + + +data AuthenticationMode = AuthLDAP + | AuthPWHash { authPWHash :: Text } + deriving (Eq, Ord, Read, Show, Generic) + +deriveJSON defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel + , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + , sumEncoding = UntaggedValue + } ''AuthenticationMode + +derivePersistFieldJSON ''AuthenticationMode + + +derivePersistFieldJSON ''Value + + +-- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@ +-- +-- Could maybe be replaced with `Structure Notification` in the long term +data NotificationTrigger = NTSubmissionRatedGraded + | NTSubmissionRated + | NTSheetActive + | NTSheetSoonInactive + | NTSheetInactive + | NTCorrectionsAssigned + | NTCorrectionsNotDistributed + | NTUserRightsUpdate + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + +instance Universe NotificationTrigger +instance Finite NotificationTrigger + +instance Hashable NotificationTrigger + +deriveJSON defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel + } ''NotificationTrigger + +instance ToJSONKey NotificationTrigger where + toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t + +instance FromJSONKey NotificationTrigger where + fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String + + +newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool } + deriving (Generic, Typeable) + deriving newtype (Eq, Ord, Read, Show) + +instance Default NotificationSettings where + def = NotificationSettings $ \case + NTSubmissionRatedGraded -> True + NTSubmissionRated -> False + NTSheetActive -> True + NTSheetSoonInactive -> False + NTSheetInactive -> True + NTCorrectionsAssigned -> True + NTCorrectionsNotDistributed -> True + NTUserRightsUpdate -> True + +instance ToJSON NotificationSettings where + toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF + +instance FromJSON NotificationSettings where + parseJSON = withObject "NotificationSettings" $ \o -> do + o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap NotificationTrigger Bool) + return . NotificationSettings $ \n -> case HashMap.lookup n o' of + Nothing -> notificationAllowed def n + Just b -> b + +derivePersistFieldJSON ''NotificationSettings + + +instance ToBackendKey SqlBackend record => Hashable (Key record) where + hashWithSalt s key = s `hashWithSalt` fromSqlKey key + +derivePersistFieldJSON ''MailLanguages + + +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) + +instance FromJSON Pseudonym where + parseJSON v@(Aeson.Number _) = do + w <- parseJSON v :: Aeson.Parser Word32 + if + | 0 <= w + , w <= fromIntegral (maxBound :: Pseudonym) + -> return $ fromIntegral w + | otherwise + -> fail "Pseudonym out auf range" + parseJSON (Aeson.String t) + = case t ^? _PseudonymText of + Just p -> return p + Nothing -> fail "Could not parse pseudonym" + parseJSON v = flip (Aeson.withArray "Pseudonym") v $ \ws -> do + ws' <- toList . map CI.mk <$> mapM parseJSON ws + case ws' ^? _PseudonymWords of + Just p -> return p + Nothing -> fail "Could not parse pseudonym words" + +instance ToJSON Pseudonym where + toJSON = toJSON . (review _PseudonymWords :: Pseudonym -> [PseudonymWord]) + +pseudonymWordlist :: [PseudonymWord] +pseudonymCharacters :: Set (CI Char) +(pseudonymWordlist, pseudonymCharacters) = $(wordlist "config/wordlist.txt") + +_PseudonymWords :: Prism' [PseudonymWord] Pseudonym +_PseudonymWords = prism' pToWords pFromWords + where + pFromWords :: [PseudonymWord] -> Maybe Pseudonym + pFromWords [w1, w2] + | Just i1 <- elemIndex w1 pseudonymWordlist + , Just i2 <- elemIndex w2 pseudonymWordlist + , i1 <= maxWord, i2 <= maxWord + = Just . Pseudonym $ shiftL (fromIntegral i1) 12 .|. fromIntegral i2 + pFromWords _ = Nothing + + pToWords :: Pseudonym -> [PseudonymWord] + pToWords (Pseudonym p) + = [ genericIndex pseudonymWordlist $ shiftR p 12 .&. maxWord + , genericIndex pseudonymWordlist $ p .&. maxWord + ] + + maxWord :: Num a => a + maxWord = 0b111111111111 + +_PseudonymText :: Prism' Text Pseudonym +_PseudonymText = prism' tToWords tFromWords . _PseudonymWords + where + tFromWords :: Text -> Maybe [PseudonymWord] + tFromWords input + | [result] <- input ^.. pseudonymFragments + = Just result + | otherwise + = Nothing + + tToWords :: [PseudonymWord] -> Text + tToWords = Text.unwords . map CI.original + +pseudonymWords :: Fold Text PseudonymWord +pseudonymWords = folding + $ \(CI.mk -> input) -> map (view _2) . fromMaybe [] . listToMaybe . groupBy ((==) `on` view _1) . sortBy (comparing $ view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist + where + distance = damerauLevenshtein `on` CI.foldedCase + -- | Arbitrary cutoff point, for reference: ispell cuts off at 1 + distanceCutoff = 2 + +pseudonymFragments :: Fold Text [PseudonymWord] +pseudonymFragments = folding + $ mapM (toListOf pseudonymWords) . (\l -> guard (length l == 2) *> l) . filter (not . null) . Text.split (\(CI.mk -> c) -> not $ Set.member c pseudonymCharacters) + + +data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer + = AuthAdmin + | AuthLecturer + | AuthCorrector + | AuthTutor + | AuthCourseRegistered + | AuthTutorialRegistered + | AuthParticipant + | AuthTime + | AuthMaterials + | AuthOwner + | AuthRated + | AuthUserSubmissions + | AuthCorrectorSubmissions + | AuthCapacity + | AuthRegisterGroup + | AuthEmpty + | AuthSelf + | AuthAuthentication + | AuthNoEscalation + | AuthRead + | AuthWrite + | AuthToken + | AuthDeprecated + | AuthDevelopment + | AuthFree + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + +instance Universe AuthTag +instance Finite AuthTag +instance Hashable AuthTag + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + } ''AuthTag + +nullaryPathPiece ''AuthTag (camelToPathPiece' 1) + +instance ToJSONKey AuthTag where + toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t + +instance FromJSONKey AuthTag where + fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String + +instance Binary AuthTag + + +newtype AuthTagActive = AuthTagActive { authTagIsActive :: AuthTag -> Bool } + deriving (Read, Show, Generic) + deriving newtype (Eq, Ord) + +instance Default AuthTagActive where + def = AuthTagActive $ \case + AuthAdmin -> False + _ -> True + +instance ToJSON AuthTagActive where + toJSON v = toJSON . HashMap.fromList $ map (id &&& authTagIsActive v) universeF + +instance FromJSON AuthTagActive where + parseJSON = withObject "AuthTagActive" $ \o -> do + o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap AuthTag Bool) + return . AuthTagActive $ \n -> case HashMap.lookup n o' of + Nothing -> authTagIsActive def n + Just b -> b + +derivePersistFieldJSON ''AuthTagActive + + +data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance Hashable a => Hashable (PredLiteral a) +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + , sumEncoding = TaggedObject "val" "var" + } ''PredLiteral + +instance PathPiece a => PathPiece (PredLiteral a) where + toPathPiece PLVariable{..} = toPathPiece plVar + toPathPiece PLNegated{..} = "¬" <> toPathPiece plVar + + fromPathPiece t = PLVariable <$> fromPathPiece t + <|> PLNegated <$> (Text.stripPrefix "¬" t >>= fromPathPiece) + +instance Binary a => Binary (PredLiteral a) + + +newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (Semigroup, Monoid) + +$(return []) + +instance ToJSON a => ToJSON (PredDNF a) where + toJSON = $(mkToJSON predNFAesonOptions ''PredDNF) +instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where + parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF) + +instance (Ord a, Binary a) => Binary (PredDNF a) where + get = PredDNF <$> Binary.get + put = Binary.put . dnfTerms + +type AuthLiteral = PredLiteral AuthTag + +type AuthDNF = PredDNF AuthTag + + +data LecturerType = CourseLecturer | CourseAssistant + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + +instance Universe LecturerType +instance Finite LecturerType + +nullaryPathPiece ''LecturerType $ camelToPathPiece' 1 +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + } ''LecturerType +derivePersistFieldJSON ''LecturerType + +instance Hashable LecturerType + + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece + } ''WeekDay + +data OccurenceSchedule = ScheduleWeekly + { scheduleDayOfWeek :: WeekDay + , scheduleStart :: TimeOfDay + , scheduleEnd :: TimeOfDay + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + , constructorTagModifier = camelToPathPiece' 1 + , tagSingleConstructors = True + , sumEncoding = TaggedObject "repeat" "schedule" + } ''OccurenceSchedule + +data OccurenceException = ExceptOccur + { exceptDay :: Day + , exceptStart :: TimeOfDay + , exceptEnd :: TimeOfDay + } + | ExceptNoOccur + { exceptTime :: LocalTime + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + , constructorTagModifier = camelToPathPiece' 1 + , sumEncoding = TaggedObject "exception" "for" + } ''OccurenceException + +data Occurences = Occurences + { occurencesScheduled :: Set OccurenceSchedule + , occurencesExceptions :: Set OccurenceException + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''Occurences +derivePersistFieldJSON ''Occurences + + +data HealthReport = HealthReport + { healthMatchingClusterConfig :: Bool + -- ^ Is the database-stored configuration we're running under still up to date? + , healthHTTPReachable :: Maybe Bool + -- ^ Can we reach a uni2work-instance with the same `ClusterId` under our configured `approot` via HTTP? + -- + -- Can be `Nothing` if we don't have a static configuration setting `appRoot` or if check is disabled in settings + , healthLDAPAdmins :: Maybe Rational + -- ^ Proportion of school admins that could be found in LDAP + -- + -- Is `Nothing` if LDAP is not configured or no users are school admins + , healthSMTPConnect :: Maybe Bool + -- ^ Can we connect to the SMTP server and say @NOOP@? + , healthWidgetMemcached :: Maybe Bool + -- ^ Can we store values in memcached and retrieve them via HTTP? + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + , omitNothingFields = True + } ''HealthReport + +-- | `HealthReport` classified (`classifyHealthReport`) by badness +-- +-- > a < b = a `worseThan` b +-- +-- Currently all consumers of this type check for @(== HealthSuccess)@; this +-- needs to be adjusted on a case-by-case basis if new constructors are added +data HealthStatus = HealthFailure | HealthSuccess + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + +instance Universe HealthStatus +instance Finite HealthStatus + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + } ''HealthStatus +nullaryPathPiece ''HealthStatus $ camelToPathPiece' 1 + +classifyHealthReport :: HealthReport -> HealthStatus +-- ^ Classify `HealthReport` by badness +classifyHealthReport HealthReport{..} = getMin . execWriter $ do -- Construction with `Writer (Min HealthStatus) a` returns worst `HealthStatus` passed to `tell` at any point + unless healthMatchingClusterConfig . tell $ Min HealthFailure + unless (fromMaybe True healthHTTPReachable) . tell $ Min HealthFailure + unless (maybe True (> 0) healthLDAPAdmins) . tell $ Min HealthFailure + unless (fromMaybe True healthSMTPConnect) . tell $ Min HealthFailure + unless (fromMaybe True healthWidgetMemcached) . tell $ Min HealthFailure + diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs new file mode 100644 index 000000000..825c07e9f --- /dev/null +++ b/src/Model/Types/Sheet.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving + , UndecidableInstances + #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text) + +module Model.Types.Sheet where + +import ClassyPrelude +import Utils +import Numeric.Natural + +import Control.Lens hiding (universe) +import Utils.Lens.TH +import GHC.Generics (Generic) +import Generics.Deriving.Monoid (memptydefault, mappenddefault) +import Data.Typeable (Typeable) +import Data.Universe +import Data.Universe.Helpers +import Data.Universe.TH +import Data.Universe.Instances.Reverse () + +import Data.NonNull.Instances () +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Map as Map +import Data.Fixed +import Data.Monoid (Sum(..)) +import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..)) + +import Data.CaseInsensitive.Instances () +import Text.Blaze (Markup) + +import Database.Persist.TH hiding (derivePersistFieldJSON) +import Model.Types.JSON +import Yesod.Core.Dispatch (PathPiece(..)) + + +---- +-- Sheet and Submission realted Model.Types + +type Count = Sum Integer +type Points = Centi + +toPoints :: Integral a => a -> Points -- deprecated +toPoints = fromIntegral + +pToI :: Points -> Integer -- deprecated +pToI = fromPoints + +fromPoints :: Integral a => Points -> a -- deprecated +fromPoints = round + +instance DisplayAble Points + +instance DisplayAble a => DisplayAble (Sum a) where + display (Sum x) = display x + +data SheetGrading + = Points { maxPoints :: Points } + | PassPoints { maxPoints, passingPoints :: Points } + | PassBinary -- non-zero means passed + deriving (Eq, Read, Show, Generic) + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece + , fieldLabelModifier = intercalate "-" . map toLower . dropEnd 1 . splitCamel + , sumEncoding = TaggedObject "type" "data" + } ''SheetGrading +derivePersistFieldJSON ''SheetGrading + +makeLenses_ ''SheetGrading + +_passingBound :: Fold SheetGrading (Either () Points) +_passingBound = folding passPts + where + passPts :: SheetGrading -> Maybe (Either () Points) + passPts (Points{}) = Nothing + passPts (PassPoints{passingPoints}) = Just $ Right passingPoints + passPts (PassBinary) = Just $ Left () + +gradingPassed :: SheetGrading -> Points -> Maybe Bool +gradingPassed gr pts = either pBinary pPoints <$> gr ^? _passingBound + where pBinary _ = pts /= 0 + pPoints b = pts >= b + + +data SheetGradeSummary = SheetGradeSummary + { numSheets :: Count -- Total number of sheets, includes all + , numSheetsPasses :: Count -- Number of sheets required to pass FKA: numGradePasses + , numSheetsPoints :: Count -- Number of sheets having points FKA: sumGradePointsd + , sumSheetsPoints :: Sum Points -- Total of all points in all sheets + -- Marking dependend + , numMarked :: Count -- Number of already marked sheets + , numMarkedPasses :: Count -- Number of already marked sheets with passes + , numMarkedPoints :: Count -- Number of already marked sheets with points + , sumMarkedPoints :: Sum Points -- Achieveable points within marked sheets + -- + , achievedPasses :: Count -- Achieved passes (within marked sheets) + , achievedPoints :: Sum Points -- Achieved points (within marked sheets) + } deriving (Generic, Read, Show, Eq) + +instance Monoid SheetGradeSummary where + mempty = memptydefault + mappend = mappenddefault + +instance Semigroup SheetGradeSummary where + (<>) = mappend -- TODO: remove for GHC > 8.4.x + +makeLenses_ ''SheetGradeSummary + +sheetGradeSum :: SheetGrading -> Maybe Points -> SheetGradeSummary +sheetGradeSum gr Nothing = mempty + { numSheets = 1 + , numSheetsPasses = bool mempty 1 $ has _passingBound gr + , numSheetsPoints = bool mempty 1 $ has _maxPoints gr + , sumSheetsPoints = maybe mempty Sum $ gr ^? _maxPoints + } +sheetGradeSum gr (Just p) = + let unmarked@SheetGradeSummary{..} = sheetGradeSum gr Nothing + in unmarked + { numMarked = numSheets + , numMarkedPasses = numSheetsPasses + , numMarkedPoints = numSheetsPoints + , sumMarkedPoints = sumSheetsPoints + , achievedPasses = fromMaybe mempty $ bool 0 1 <$> gradingPassed gr p + , achievedPoints = bool mempty (Sum p) $ has _maxPoints gr + } + + +data SheetType + = NotGraded + | Normal { grading :: SheetGrading } + | Bonus { grading :: SheetGrading } + | Informational { grading :: SheetGrading } + deriving (Eq, Read, Show, Generic) + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece + , fieldLabelModifier = camelToPathPiece + , sumEncoding = TaggedObject "type" "data" + } ''SheetType +derivePersistFieldJSON ''SheetType + +data SheetTypeSummary = SheetTypeSummary + { normalSummary + , bonusSummary + , informationalSummary :: SheetGradeSummary + , numNotGraded :: Count + } deriving (Generic, Read, Show, Eq) + +instance Monoid SheetTypeSummary where + mempty = memptydefault + mappend = mappenddefault + +instance Semigroup SheetTypeSummary where + (<>) = mappend -- TODO: remove for GHC > 8.4.x + +makeLenses_ ''SheetTypeSummary + +sheetTypeSum :: SheetType -> Maybe Points -> SheetTypeSummary +sheetTypeSum Bonus{..} mps = mempty { bonusSummary = sheetGradeSum grading mps } +sheetTypeSum Normal{..} mps = mempty { normalSummary = sheetGradeSum grading mps } +sheetTypeSum Informational{..} mps = mempty { informationalSummary = sheetGradeSum grading mps } +sheetTypeSum NotGraded _ = mempty { numNotGraded = Sum 1 } + +data SheetGroup + = Arbitrary { maxParticipants :: Natural } + | RegisteredGroups + | NoGroups + deriving (Show, Read, Eq, Generic) +deriveJSON defaultOptions ''SheetGroup +derivePersistFieldJSON ''SheetGroup + +makeLenses_ ''SheetGroup + +data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking + deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) +derivePersistField "SheetFileType" + +instance Universe SheetFileType where universe = universeDef +instance Finite SheetFileType + +instance PathPiece SheetFileType where + toPathPiece SheetExercise = "file" + toPathPiece SheetHint = "hint" + toPathPiece SheetSolution = "solution" + toPathPiece SheetMarking = "marking" + fromPathPiece = finiteFromPathPiece + +sheetFile2markup :: SheetFileType -> Markup +sheetFile2markup SheetExercise = iconQuestion +sheetFile2markup SheetHint = iconHint +sheetFile2markup SheetSolution = iconSolution +sheetFile2markup SheetMarking = iconMarking + +-- $(deriveSimpleWith ''DisplayAble 'display (drop 17) ''SheetFileType) +instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instance in Foundation + display SheetExercise = "Aufgabenstellung" + display SheetHint = "Hinweise" + display SheetSolution = "Musterlösung" + display SheetMarking = "Korrekturhinweise" + +-- partitionFileType' :: Ord a => [(SheetFileType,a)] -> Map SheetFileType (Set a) +-- partitionFileType' = groupMap + +partitionFileType :: Ord a => [(SheetFileType,a)] -> SheetFileType -> Set a +partitionFileType fs t = Map.findWithDefault Set.empty t . Map.fromListWith Set.union $ map (over _2 Set.singleton) fs + +data SubmissionFileType = SubmissionOriginal | SubmissionCorrected + deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) + +instance Universe SubmissionFileType where universe = universeDef +instance Finite SubmissionFileType + +submissionFileTypeIsUpdate :: SubmissionFileType -> Bool +submissionFileTypeIsUpdate SubmissionOriginal = False +submissionFileTypeIsUpdate SubmissionCorrected = True + +isUpdateSubmissionFileType :: Bool -> SubmissionFileType +isUpdateSubmissionFileType False = SubmissionOriginal +isUpdateSubmissionFileType True = SubmissionCorrected + +instance PathPiece SubmissionFileType where + toPathPiece SubmissionOriginal = "original" + toPathPiece SubmissionCorrected = "corrected" + fromPathPiece = finiteFromPathPiece + +instance DisplayAble SubmissionFileType where + display SubmissionOriginal = "Abgabe" + display SubmissionCorrected = "Korrektur" + +{- +data DA = forall a . (DisplayAble a) => DA a + +instance DisplayAble DA where + display (DA x) = display x +-} + + +data UploadMode = NoUpload | Upload { unpackZips :: Bool } + deriving (Show, Read, Eq, Ord, Generic) + +deriveFinite ''UploadMode + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece + , fieldLabelModifier = camelToPathPiece + , sumEncoding = TaggedObject "mode" "settings" + }''UploadMode +derivePersistFieldJSON ''UploadMode + +instance PathPiece UploadMode where + toPathPiece = \case + NoUpload -> "no-upload" + Upload True -> "unpack" + Upload False -> "no-unpack" + fromPathPiece = finiteFromPathPiece + +data SubmissionMode = SubmissionMode + { submissionModeCorrector :: Bool + , submissionModeUser :: Maybe UploadMode + } + deriving (Show, Read, Eq, Ord, Generic) + +deriveFinite ''SubmissionMode + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 2 + } ''SubmissionMode +derivePersistFieldJSON ''SubmissionMode + +finitePathPiece ''SubmissionMode + [ "no-submissions" + , "no-upload" + , "no-unpack" + , "unpack" + , "correctors" + , "correctors+no-upload" + , "correctors+no-unpack" + , "correctors+unpack" + ] + +data SubmissionModeDescr = SubmissionModeNone + | SubmissionModeCorrector + | SubmissionModeUser + | SubmissionModeBoth + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe SubmissionModeDescr +instance Finite SubmissionModeDescr + +finitePathPiece ''SubmissionModeDescr + [ "no-submissions" + , "correctors" + , "users" + , "correctors+users" + ] + +classifySubmissionMode :: SubmissionMode -> SubmissionModeDescr +classifySubmissionMode (SubmissionMode False Nothing ) = SubmissionModeNone +classifySubmissionMode (SubmissionMode True Nothing ) = SubmissionModeCorrector +classifySubmissionMode (SubmissionMode False (Just _)) = SubmissionModeUser +classifySubmissionMode (SubmissionMode True (Just _)) = SubmissionModeBoth + + +data ExamStatus = Attended | NoShow | Voided + deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) +derivePersistField "ExamStatus" + +-- | Specify a corrector's workload +data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rational } + = Load { byTutorial :: Maybe Bool -- ^ @Just@ all from Tutorial, @True@ if counting towards overall workload + , byProportion :: Rational -- ^ workload proportion of all submission not assigned to tutorial leaders + } + deriving (Show, Read, Eq, Ord, Generic) + +deriveJSON defaultOptions ''Load +derivePersistFieldJSON ''Load + +instance Hashable Load + +instance Semigroup Load where + (Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop') + where + byTut'' + | Nothing <- byTut = byTut' + | Nothing <- byTut' = byTut + | Just a <- byTut + , Just b <- byTut' = Just $ a || b + +instance Monoid Load where + mempty = Load Nothing 0 + mappend = (<>) + +{- Use (is _ByTutorial) instead of this unneeded definition: + isByTutorial :: Load -> Bool + isByTutorial (ByTutorial {}) = True + isByTutorial _ = False +-} \ No newline at end of file From 81441717ce44adf7e3d547ef80e691d037bd678c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 15 May 2019 22:33:57 +0200 Subject: [PATCH 02/13] Quiet hlint, one more split to Model.Types --- src/Model/Types.hs | 6 +- src/Model/Types/DateTime.hs | 6 +- src/Model/Types/Misc.hs | 399 ++-------------------------------- src/Model/Types/Security.hs | 411 ++++++++++++++++++++++++++++++++++++ src/Model/Types/Sheet.hs | 29 +-- 5 files changed, 444 insertions(+), 407 deletions(-) create mode 100644 src/Model/Types/Security.hs diff --git a/src/Model/Types.hs b/src/Model/Types.hs index b812d529c..b1692283c 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving - , UndecidableInstances - #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text) @@ -9,6 +7,7 @@ module Model.Types ( module Model.Types , module Model.Types.Sheet , module Model.Types.DateTime + , module Model.Types.Security , module Model.Types.Misc , module Numeric.Natural , module Mail @@ -38,6 +37,7 @@ import Numeric.Natural import Model.Types.Sheet import Model.Types.DateTime +import Model.Types.Security import Model.Types.Misc ---- diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index 05fe00594..cb7b2999d 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -9,7 +9,7 @@ module Model.Types.DateTime where import ClassyPrelude import GHC.Generics (Generic) import Utils -import Control.Lens hiding (universe) +import Control.Lens import Data.NonNull.Instances () import Data.Typeable (Typeable) import Data.Universe.Instances.Reverse () @@ -51,7 +51,7 @@ seasonFromChar c where (~=) = (==) `on` CI.mk -instance DisplayAble Season +-- instance DisplayAble Season data TermIdentifier = TermIdentifier { year :: Integer -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar' @@ -114,7 +114,7 @@ termFromRational :: Rational -> TermIdentifier termFromRational n = TermIdentifier{..} where year = floor n - remainder = n - (fromInteger $ floor n) + remainder = n - fromInteger (floor n) season | remainder == 0 = Summer | otherwise = Winter diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index 226665e63..0affd8b70 100644 --- a/src/Model/Types/Misc.hs +++ b/src/Model/Types/Misc.hs @@ -8,87 +8,45 @@ module Model.Types.Misc where import ClassyPrelude import Utils -import Control.Lens hiding (universe) +import Control.Lens +import Data.NonNull.Instances () import Data.Set (Set) -import qualified Data.Set as Set import Data.Maybe (fromJust) import Data.Universe import Data.Universe.Helpers -import Data.UUID.Types (UUID) -import qualified Data.UUID.Types as UUID -import Data.NonNull.Instances () - -import Data.Default - -import Database.Persist.TH hiding (derivePersistFieldJSON) -import Model.Types.JSON -import Database.Persist.Class -import Database.Persist.Sql - -import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Lens as Text - -import qualified Data.HashMap.Strict as HashMap - -import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Data.CaseInsensitive.Instances () +import Database.Persist.TH hiding (derivePersistFieldJSON) +import Model.Types.JSON + import Yesod.Core.Dispatch (PathPiece(..)) -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Types as Aeson -import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withObject, Value()) -import Data.Aeson.Types (toJSONKeyText) -import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..), mkToJSON, mkParseJSON) +import Data.Aeson (Value()) +import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..)) import GHC.Generics (Generic) import Data.Typeable (Typeable) import Data.Universe.Instances.Reverse () -import Mail (MailLanguages(..)) - -import Data.Word.Word24 (Word24) -import Data.Bits -import Data.Ix -import Data.List (genericIndex, elemIndex) -import System.Random (Random(..)) -import Data.Data (Data) - -import Model.Types.Wordlist -import Data.Text.Metrics (damerauLevenshtein) - -import Data.Binary (Binary) -import qualified Data.Binary as Binary - -import Time.Types (WeekDay(..)) import Data.Time.LocalTime (LocalTime, TimeOfDay) - -import Data.Semigroup (Min(..)) -import Control.Monad.Trans.Writer (execWriter) -import Control.Monad.Writer.Class (MonadWriter(..)) +import Time.Types (WeekDay(..)) +----- +-- Miscellaneous Model.Types +derivePersistFieldJSON ''Value data StudyFieldType = FieldPrimary | FieldSecondary deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic) derivePersistField "StudyFieldType" -instance PersistField UUID where - toPersistValue = PersistDbSpecific . UUID.toASCIIBytes - fromPersistValue (PersistText t) = maybe (Left "Failed to parse UUID") Right $ UUID.fromText t - fromPersistValue (PersistByteString bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs - fromPersistValue (PersistDbSpecific bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs - fromPersistValue x = Left $ "Expected UUID, received: " <> tshow x - -instance PersistFieldSql UUID where - sqlType _ = SqlOther "uuid" - -instance DisplayAble StudyFieldType +-- instance DisplayAble StudyFieldType data Theme = ThemeDefault @@ -138,290 +96,6 @@ nullaryPathPiece ''CorrectorState (camelToPathPiece' 1) derivePersistField "CorrectorState" -data AuthenticationMode = AuthLDAP - | AuthPWHash { authPWHash :: Text } - deriving (Eq, Ord, Read, Show, Generic) - -deriveJSON defaultOptions - { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel - , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel - , sumEncoding = UntaggedValue - } ''AuthenticationMode - -derivePersistFieldJSON ''AuthenticationMode - - -derivePersistFieldJSON ''Value - - --- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@ --- --- Could maybe be replaced with `Structure Notification` in the long term -data NotificationTrigger = NTSubmissionRatedGraded - | NTSubmissionRated - | NTSheetActive - | NTSheetSoonInactive - | NTSheetInactive - | NTCorrectionsAssigned - | NTCorrectionsNotDistributed - | NTUserRightsUpdate - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - -instance Universe NotificationTrigger -instance Finite NotificationTrigger - -instance Hashable NotificationTrigger - -deriveJSON defaultOptions - { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel - } ''NotificationTrigger - -instance ToJSONKey NotificationTrigger where - toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t - -instance FromJSONKey NotificationTrigger where - fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String - - -newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool } - deriving (Generic, Typeable) - deriving newtype (Eq, Ord, Read, Show) - -instance Default NotificationSettings where - def = NotificationSettings $ \case - NTSubmissionRatedGraded -> True - NTSubmissionRated -> False - NTSheetActive -> True - NTSheetSoonInactive -> False - NTSheetInactive -> True - NTCorrectionsAssigned -> True - NTCorrectionsNotDistributed -> True - NTUserRightsUpdate -> True - -instance ToJSON NotificationSettings where - toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF - -instance FromJSON NotificationSettings where - parseJSON = withObject "NotificationSettings" $ \o -> do - o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap NotificationTrigger Bool) - return . NotificationSettings $ \n -> case HashMap.lookup n o' of - Nothing -> notificationAllowed def n - Just b -> b - -derivePersistFieldJSON ''NotificationSettings - - -instance ToBackendKey SqlBackend record => Hashable (Key record) where - hashWithSalt s key = s `hashWithSalt` fromSqlKey key - -derivePersistFieldJSON ''MailLanguages - - -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) - -instance FromJSON Pseudonym where - parseJSON v@(Aeson.Number _) = do - w <- parseJSON v :: Aeson.Parser Word32 - if - | 0 <= w - , w <= fromIntegral (maxBound :: Pseudonym) - -> return $ fromIntegral w - | otherwise - -> fail "Pseudonym out auf range" - parseJSON (Aeson.String t) - = case t ^? _PseudonymText of - Just p -> return p - Nothing -> fail "Could not parse pseudonym" - parseJSON v = flip (Aeson.withArray "Pseudonym") v $ \ws -> do - ws' <- toList . map CI.mk <$> mapM parseJSON ws - case ws' ^? _PseudonymWords of - Just p -> return p - Nothing -> fail "Could not parse pseudonym words" - -instance ToJSON Pseudonym where - toJSON = toJSON . (review _PseudonymWords :: Pseudonym -> [PseudonymWord]) - -pseudonymWordlist :: [PseudonymWord] -pseudonymCharacters :: Set (CI Char) -(pseudonymWordlist, pseudonymCharacters) = $(wordlist "config/wordlist.txt") - -_PseudonymWords :: Prism' [PseudonymWord] Pseudonym -_PseudonymWords = prism' pToWords pFromWords - where - pFromWords :: [PseudonymWord] -> Maybe Pseudonym - pFromWords [w1, w2] - | Just i1 <- elemIndex w1 pseudonymWordlist - , Just i2 <- elemIndex w2 pseudonymWordlist - , i1 <= maxWord, i2 <= maxWord - = Just . Pseudonym $ shiftL (fromIntegral i1) 12 .|. fromIntegral i2 - pFromWords _ = Nothing - - pToWords :: Pseudonym -> [PseudonymWord] - pToWords (Pseudonym p) - = [ genericIndex pseudonymWordlist $ shiftR p 12 .&. maxWord - , genericIndex pseudonymWordlist $ p .&. maxWord - ] - - maxWord :: Num a => a - maxWord = 0b111111111111 - -_PseudonymText :: Prism' Text Pseudonym -_PseudonymText = prism' tToWords tFromWords . _PseudonymWords - where - tFromWords :: Text -> Maybe [PseudonymWord] - tFromWords input - | [result] <- input ^.. pseudonymFragments - = Just result - | otherwise - = Nothing - - tToWords :: [PseudonymWord] -> Text - tToWords = Text.unwords . map CI.original - -pseudonymWords :: Fold Text PseudonymWord -pseudonymWords = folding - $ \(CI.mk -> input) -> map (view _2) . fromMaybe [] . listToMaybe . groupBy ((==) `on` view _1) . sortBy (comparing $ view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist - where - distance = damerauLevenshtein `on` CI.foldedCase - -- | Arbitrary cutoff point, for reference: ispell cuts off at 1 - distanceCutoff = 2 - -pseudonymFragments :: Fold Text [PseudonymWord] -pseudonymFragments = folding - $ mapM (toListOf pseudonymWords) . (\l -> guard (length l == 2) *> l) . filter (not . null) . Text.split (\(CI.mk -> c) -> not $ Set.member c pseudonymCharacters) - - -data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer - = AuthAdmin - | AuthLecturer - | AuthCorrector - | AuthTutor - | AuthCourseRegistered - | AuthTutorialRegistered - | AuthParticipant - | AuthTime - | AuthMaterials - | AuthOwner - | AuthRated - | AuthUserSubmissions - | AuthCorrectorSubmissions - | AuthCapacity - | AuthRegisterGroup - | AuthEmpty - | AuthSelf - | AuthAuthentication - | AuthNoEscalation - | AuthRead - | AuthWrite - | AuthToken - | AuthDeprecated - | AuthDevelopment - | AuthFree - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) - -instance Universe AuthTag -instance Finite AuthTag -instance Hashable AuthTag - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 - } ''AuthTag - -nullaryPathPiece ''AuthTag (camelToPathPiece' 1) - -instance ToJSONKey AuthTag where - toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t - -instance FromJSONKey AuthTag where - fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String - -instance Binary AuthTag - - -newtype AuthTagActive = AuthTagActive { authTagIsActive :: AuthTag -> Bool } - deriving (Read, Show, Generic) - deriving newtype (Eq, Ord) - -instance Default AuthTagActive where - def = AuthTagActive $ \case - AuthAdmin -> False - _ -> True - -instance ToJSON AuthTagActive where - toJSON v = toJSON . HashMap.fromList $ map (id &&& authTagIsActive v) universeF - -instance FromJSON AuthTagActive where - parseJSON = withObject "AuthTagActive" $ \o -> do - o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap AuthTag Bool) - return . AuthTagActive $ \n -> case HashMap.lookup n o' of - Nothing -> authTagIsActive def n - Just b -> b - -derivePersistFieldJSON ''AuthTagActive - - -data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a } - deriving (Eq, Ord, Read, Show, Generic, Typeable) - -instance Hashable a => Hashable (PredLiteral a) -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 - , sumEncoding = TaggedObject "val" "var" - } ''PredLiteral - -instance PathPiece a => PathPiece (PredLiteral a) where - toPathPiece PLVariable{..} = toPathPiece plVar - toPathPiece PLNegated{..} = "¬" <> toPathPiece plVar - - fromPathPiece t = PLVariable <$> fromPathPiece t - <|> PLNegated <$> (Text.stripPrefix "¬" t >>= fromPathPiece) - -instance Binary a => Binary (PredLiteral a) - - -newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) } - deriving (Eq, Ord, Read, Show, Generic, Typeable) - deriving newtype (Semigroup, Monoid) - -$(return []) - -instance ToJSON a => ToJSON (PredDNF a) where - toJSON = $(mkToJSON predNFAesonOptions ''PredDNF) -instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where - parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF) - -instance (Ord a, Binary a) => Binary (PredDNF a) where - get = PredDNF <$> Binary.get - put = Binary.put . dnfTerms - -type AuthLiteral = PredLiteral AuthTag - -type AuthDNF = PredDNF AuthTag - - data LecturerType = CourseLecturer | CourseAssistant deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) @@ -481,52 +155,3 @@ deriveJSON defaultOptions } ''Occurences derivePersistFieldJSON ''Occurences - -data HealthReport = HealthReport - { healthMatchingClusterConfig :: Bool - -- ^ Is the database-stored configuration we're running under still up to date? - , healthHTTPReachable :: Maybe Bool - -- ^ Can we reach a uni2work-instance with the same `ClusterId` under our configured `approot` via HTTP? - -- - -- Can be `Nothing` if we don't have a static configuration setting `appRoot` or if check is disabled in settings - , healthLDAPAdmins :: Maybe Rational - -- ^ Proportion of school admins that could be found in LDAP - -- - -- Is `Nothing` if LDAP is not configured or no users are school admins - , healthSMTPConnect :: Maybe Bool - -- ^ Can we connect to the SMTP server and say @NOOP@? - , healthWidgetMemcached :: Maybe Bool - -- ^ Can we store values in memcached and retrieve them via HTTP? - } deriving (Eq, Ord, Read, Show, Generic, Typeable) - -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 - , omitNothingFields = True - } ''HealthReport - --- | `HealthReport` classified (`classifyHealthReport`) by badness --- --- > a < b = a `worseThan` b --- --- Currently all consumers of this type check for @(== HealthSuccess)@; this --- needs to be adjusted on a case-by-case basis if new constructors are added -data HealthStatus = HealthFailure | HealthSuccess - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - -instance Universe HealthStatus -instance Finite HealthStatus - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 - } ''HealthStatus -nullaryPathPiece ''HealthStatus $ camelToPathPiece' 1 - -classifyHealthReport :: HealthReport -> HealthStatus --- ^ Classify `HealthReport` by badness -classifyHealthReport HealthReport{..} = getMin . execWriter $ do -- Construction with `Writer (Min HealthStatus) a` returns worst `HealthStatus` passed to `tell` at any point - unless healthMatchingClusterConfig . tell $ Min HealthFailure - unless (fromMaybe True healthHTTPReachable) . tell $ Min HealthFailure - unless (maybe True (> 0) healthLDAPAdmins) . tell $ Min HealthFailure - unless (fromMaybe True healthSMTPConnect) . tell $ Min HealthFailure - unless (fromMaybe True healthWidgetMemcached) . tell $ Min HealthFailure - diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs new file mode 100644 index 000000000..27be35f81 --- /dev/null +++ b/src/Model/Types/Security.hs @@ -0,0 +1,411 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving + , UndecidableInstances + #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text) + +module Model.Types.Security where + + +import ClassyPrelude +import Utils +import Control.Lens hiding (universe) + +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Universe +import Data.UUID.Types (UUID) +import qualified Data.UUID.Types as UUID + +import Data.NonNull.Instances () + +import Data.Default + +import Model.Types.JSON +import Database.Persist.Class +import Database.Persist.Sql + +import Data.Text (Text) +import qualified Data.Text as Text + +import qualified Data.HashMap.Strict as HashMap + +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import Data.CaseInsensitive.Instances () + +import Yesod.Core.Dispatch (PathPiece(..)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withObject) +import Data.Aeson.Types (toJSONKeyText) +import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..), mkToJSON, mkParseJSON) + +import GHC.Generics (Generic) +import Data.Typeable (Typeable) + +import Data.Universe.Instances.Reverse () + +import Mail (MailLanguages(..)) + +import Data.Word.Word24 (Word24) +import Data.Bits +import Data.Ix +import Data.List (genericIndex, elemIndex) +import System.Random (Random(..)) +import Data.Data (Data) + +import Model.Types.Wordlist +import Data.Text.Metrics (damerauLevenshtein) + +import Data.Binary (Binary) +import qualified Data.Binary as Binary + +import Data.Semigroup (Min(..)) +import Control.Monad.Trans.Writer (execWriter) +import Control.Monad.Writer.Class (MonadWriter(..)) + + +---- +-- Security, Authentification, Notification Stuff + +instance PersistField UUID where + toPersistValue = PersistDbSpecific . UUID.toASCIIBytes + fromPersistValue (PersistText t) = maybe (Left "Failed to parse UUID") Right $ UUID.fromText t + fromPersistValue (PersistByteString bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs + fromPersistValue (PersistDbSpecific bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs + fromPersistValue x = Left $ "Expected UUID, received: " <> tshow x + +instance PersistFieldSql UUID where + sqlType _ = SqlOther "uuid" + + +data AuthenticationMode = AuthLDAP + | AuthPWHash { authPWHash :: Text } + deriving (Eq, Ord, Read, Show, Generic) + +deriveJSON defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel + , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + , sumEncoding = UntaggedValue + } ''AuthenticationMode + +derivePersistFieldJSON ''AuthenticationMode + + + +-- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@ +-- +-- Could maybe be replaced with `Structure Notification` in the long term +data NotificationTrigger = NTSubmissionRatedGraded + | NTSubmissionRated + | NTSheetActive + | NTSheetSoonInactive + | NTSheetInactive + | NTCorrectionsAssigned + | NTCorrectionsNotDistributed + | NTUserRightsUpdate + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + +instance Universe NotificationTrigger +instance Finite NotificationTrigger + +instance Hashable NotificationTrigger + +deriveJSON defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel + } ''NotificationTrigger + +instance ToJSONKey NotificationTrigger where + toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t + +instance FromJSONKey NotificationTrigger where + fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String + + +newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool } + deriving (Generic, Typeable) + deriving newtype (Eq, Ord, Read, Show) + +instance Default NotificationSettings where + def = NotificationSettings $ \case + NTSubmissionRatedGraded -> True + NTSubmissionRated -> False + NTSheetActive -> True + NTSheetSoonInactive -> False + NTSheetInactive -> True + NTCorrectionsAssigned -> True + NTCorrectionsNotDistributed -> True + NTUserRightsUpdate -> True + +instance ToJSON NotificationSettings where + toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF + +instance FromJSON NotificationSettings where + parseJSON = withObject "NotificationSettings" $ \o -> do + o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap NotificationTrigger Bool) + return . NotificationSettings $ \n -> case HashMap.lookup n o' of + Nothing -> notificationAllowed def n + Just b -> b + +derivePersistFieldJSON ''NotificationSettings + + +instance ToBackendKey SqlBackend record => Hashable (Key record) where + hashWithSalt s key = s `hashWithSalt` fromSqlKey key + +derivePersistFieldJSON ''MailLanguages + + +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) + +instance FromJSON Pseudonym where + parseJSON v@(Aeson.Number _) = do + w <- parseJSON v :: Aeson.Parser Word32 + if + | 0 <= w + , w <= fromIntegral (maxBound :: Pseudonym) + -> return $ fromIntegral w + | otherwise + -> fail "Pseudonym out auf range" + parseJSON (Aeson.String t) + = case t ^? _PseudonymText of + Just p -> return p + Nothing -> fail "Could not parse pseudonym" + parseJSON v = flip (Aeson.withArray "Pseudonym") v $ \ws -> do + ws' <- toList . map CI.mk <$> mapM parseJSON ws + case ws' ^? _PseudonymWords of + Just p -> return p + Nothing -> fail "Could not parse pseudonym words" + +instance ToJSON Pseudonym where + toJSON = toJSON . (review _PseudonymWords :: Pseudonym -> [PseudonymWord]) + +pseudonymWordlist :: [PseudonymWord] +pseudonymCharacters :: Set (CI Char) +(pseudonymWordlist, pseudonymCharacters) = $(wordlist "config/wordlist.txt") + +_PseudonymWords :: Prism' [PseudonymWord] Pseudonym +_PseudonymWords = prism' pToWords pFromWords + where + pFromWords :: [PseudonymWord] -> Maybe Pseudonym + pFromWords [w1, w2] + | Just i1 <- elemIndex w1 pseudonymWordlist + , Just i2 <- elemIndex w2 pseudonymWordlist + , i1 <= maxWord, i2 <= maxWord + = Just . Pseudonym $ shiftL (fromIntegral i1) 12 .|. fromIntegral i2 + pFromWords _ = Nothing + + pToWords :: Pseudonym -> [PseudonymWord] + pToWords (Pseudonym p) + = [ genericIndex pseudonymWordlist $ shiftR p 12 .&. maxWord + , genericIndex pseudonymWordlist $ p .&. maxWord + ] + + maxWord :: Num a => a + maxWord = 0b111111111111 + +_PseudonymText :: Prism' Text Pseudonym +_PseudonymText = prism' tToWords tFromWords . _PseudonymWords + where + tFromWords :: Text -> Maybe [PseudonymWord] + tFromWords input + | [result] <- input ^.. pseudonymFragments + = Just result + | otherwise + = Nothing + + tToWords :: [PseudonymWord] -> Text + tToWords = Text.unwords . map CI.original + +pseudonymWords :: Fold Text PseudonymWord +pseudonymWords = folding + $ \(CI.mk -> input) -> map (view _2) . fromMaybe [] . listToMaybe . groupBy ((==) `on` view _1) . sortBy (comparing $ view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist + where + distance = damerauLevenshtein `on` CI.foldedCase + -- | Arbitrary cutoff point, for reference: ispell cuts off at 1 + distanceCutoff = 2 + +pseudonymFragments :: Fold Text [PseudonymWord] +pseudonymFragments = folding + $ mapM (toListOf pseudonymWords) . (\l -> guard (length l == 2) *> l) . filter (not . null) . Text.split (\(CI.mk -> c) -> not $ Set.member c pseudonymCharacters) + + +data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer + = AuthAdmin + | AuthLecturer + | AuthCorrector + | AuthTutor + | AuthCourseRegistered + | AuthTutorialRegistered + | AuthParticipant + | AuthTime + | AuthMaterials + | AuthOwner + | AuthRated + | AuthUserSubmissions + | AuthCorrectorSubmissions + | AuthCapacity + | AuthRegisterGroup + | AuthEmpty + | AuthSelf + | AuthAuthentication + | AuthNoEscalation + | AuthRead + | AuthWrite + | AuthToken + | AuthDeprecated + | AuthDevelopment + | AuthFree + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + +instance Universe AuthTag +instance Finite AuthTag +instance Hashable AuthTag + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + } ''AuthTag + +nullaryPathPiece ''AuthTag (camelToPathPiece' 1) + +instance ToJSONKey AuthTag where + toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t + +instance FromJSONKey AuthTag where + fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String + +instance Binary AuthTag + + +newtype AuthTagActive = AuthTagActive { authTagIsActive :: AuthTag -> Bool } + deriving (Read, Show, Generic) + deriving newtype (Eq, Ord) + +instance Default AuthTagActive where + def = AuthTagActive $ \case + AuthAdmin -> False + _ -> True + +instance ToJSON AuthTagActive where + toJSON v = toJSON . HashMap.fromList $ map (id &&& authTagIsActive v) universeF + +instance FromJSON AuthTagActive where + parseJSON = withObject "AuthTagActive" $ \o -> do + o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap AuthTag Bool) + return . AuthTagActive $ \n -> case HashMap.lookup n o' of + Nothing -> authTagIsActive def n + Just b -> b + +derivePersistFieldJSON ''AuthTagActive + + +data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance Hashable a => Hashable (PredLiteral a) +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + , sumEncoding = TaggedObject "val" "var" + } ''PredLiteral + +instance PathPiece a => PathPiece (PredLiteral a) where + toPathPiece PLVariable{..} = toPathPiece plVar + toPathPiece PLNegated{..} = "¬" <> toPathPiece plVar + + fromPathPiece t = PLVariable <$> fromPathPiece t + <|> PLNegated <$> (Text.stripPrefix "¬" t >>= fromPathPiece) + +instance Binary a => Binary (PredLiteral a) + + +newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (Semigroup, Monoid) + +$(return []) + +instance ToJSON a => ToJSON (PredDNF a) where + toJSON = $(mkToJSON predNFAesonOptions ''PredDNF) +instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where + parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF) + +instance (Ord a, Binary a) => Binary (PredDNF a) where + get = PredDNF <$> Binary.get + put = Binary.put . dnfTerms + +type AuthLiteral = PredLiteral AuthTag + +type AuthDNF = PredDNF AuthTag + + +data HealthReport = HealthReport + { healthMatchingClusterConfig :: Bool + -- ^ Is the database-stored configuration we're running under still up to date? + , healthHTTPReachable :: Maybe Bool + -- ^ Can we reach a uni2work-instance with the same `ClusterId` under our configured `approot` via HTTP? + -- + -- Can be `Nothing` if we don't have a static configuration setting `appRoot` or if check is disabled in settings + , healthLDAPAdmins :: Maybe Rational + -- ^ Proportion of school admins that could be found in LDAP + -- + -- Is `Nothing` if LDAP is not configured or no users are school admins + , healthSMTPConnect :: Maybe Bool + -- ^ Can we connect to the SMTP server and say @NOOP@? + , healthWidgetMemcached :: Maybe Bool + -- ^ Can we store values in memcached and retrieve them via HTTP? + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + , omitNothingFields = True + } ''HealthReport + +-- | `HealthReport` classified (`classifyHealthReport`) by badness +-- +-- > a < b = a `worseThan` b +-- +-- Currently all consumers of this type check for @(== HealthSuccess)@; this +-- needs to be adjusted on a case-by-case basis if new constructors are added +data HealthStatus = HealthFailure | HealthSuccess + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + +instance Universe HealthStatus +instance Finite HealthStatus + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + } ''HealthStatus +nullaryPathPiece ''HealthStatus $ camelToPathPiece' 1 + +classifyHealthReport :: HealthReport -> HealthStatus +-- ^ Classify `HealthReport` by badness +classifyHealthReport HealthReport{..} = getMin . execWriter $ do -- Construction with `Writer (Min HealthStatus) a` returns worst `HealthStatus` passed to `tell` at any point + unless healthMatchingClusterConfig . tell $ Min HealthFailure + unless (fromMaybe True healthHTTPReachable) . tell $ Min HealthFailure + unless (maybe True (> 0) healthLDAPAdmins) . tell $ Min HealthFailure + unless (fromMaybe True healthSMTPConnect) . tell $ Min HealthFailure + unless (fromMaybe True healthWidgetMemcached) . tell $ Min HealthFailure + diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs index 825c07e9f..a754d0d0b 100644 --- a/src/Model/Types/Sheet.hs +++ b/src/Model/Types/Sheet.hs @@ -9,7 +9,7 @@ import ClassyPrelude import Utils import Numeric.Natural -import Control.Lens hiding (universe) +import Control.Lens import Utils.Lens.TH import GHC.Generics (Generic) import Generics.Deriving.Monoid (memptydefault, mappenddefault) @@ -35,6 +35,7 @@ import Model.Types.JSON import Yesod.Core.Dispatch (PathPiece(..)) + ---- -- Sheet and Submission realted Model.Types @@ -53,7 +54,7 @@ fromPoints = round instance DisplayAble Points instance DisplayAble a => DisplayAble (Sum a) where - display (Sum x) = display x + display (Sum x) = display x data SheetGrading = Points { maxPoints :: Points } @@ -74,9 +75,9 @@ _passingBound :: Fold SheetGrading (Either () Points) _passingBound = folding passPts where passPts :: SheetGrading -> Maybe (Either () Points) - passPts (Points{}) = Nothing - passPts (PassPoints{passingPoints}) = Just $ Right passingPoints - passPts (PassBinary) = Just $ Left () + passPts Points{} = Nothing + passPts PassPoints{passingPoints} = Just $ Right passingPoints + passPts PassBinary = Just $ Left () gradingPassed :: SheetGrading -> Points -> Maybe Bool gradingPassed gr pts = either pBinary pPoints <$> gr ^? _passingBound @@ -122,7 +123,7 @@ sheetGradeSum gr (Just p) = , numMarkedPasses = numSheetsPasses , numMarkedPoints = numSheetsPoints , sumMarkedPoints = sumSheetsPoints - , achievedPasses = fromMaybe mempty $ bool 0 1 <$> gradingPassed gr p + , achievedPasses = maybe mempty (bool 0 1) (gradingPassed gr p) , achievedPoints = bool mempty (Sum p) $ has _maxPoints gr } @@ -194,11 +195,11 @@ sheetFile2markup SheetSolution = iconSolution sheetFile2markup SheetMarking = iconMarking -- $(deriveSimpleWith ''DisplayAble 'display (drop 17) ''SheetFileType) -instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instance in Foundation - display SheetExercise = "Aufgabenstellung" - display SheetHint = "Hinweise" - display SheetSolution = "Musterlösung" - display SheetMarking = "Korrekturhinweise" +-- instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instance in Foundation +-- display SheetExercise = "Aufgabenstellung" +-- display SheetHint = "Hinweise" +-- display SheetSolution = "Musterlösung" +-- display SheetMarking = "Korrekturhinweise" -- partitionFileType' :: Ord a => [(SheetFileType,a)] -> Map SheetFileType (Set a) -- partitionFileType' = groupMap @@ -225,9 +226,9 @@ instance PathPiece SubmissionFileType where toPathPiece SubmissionCorrected = "corrected" fromPathPiece = finiteFromPathPiece -instance DisplayAble SubmissionFileType where - display SubmissionOriginal = "Abgabe" - display SubmissionCorrected = "Korrektur" +-- instance DisplayAble SubmissionFileType where +-- display SubmissionOriginal = "Abgabe" +-- display SubmissionCorrected = "Korrektur" {- data DA = forall a . (DisplayAble a) => DA a From 5a9ca00ff6d7f4f056b1e38d25dd7c37f21c6835 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 16 May 2019 11:18:19 +0200 Subject: [PATCH 03/13] Fix #379 --- messages/uniworx/de.msg | 8 ++++---- src/Foundation.hs | 14 +++++++------- src/Handler/Corrections.hs | 2 +- src/Utils.hs | 4 ++-- 4 files changed, 14 insertions(+), 14 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 05b9b6579..ccd4eac45 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -64,7 +64,7 @@ TermActive: Aktiv SchoolListHeading: Übersicht über verwaltete Institute -SchoolHeading school@SchoolName: Übersicht #{display school} +SchoolHeading school@SchoolName: Übersicht #{school} LectureStart: Beginn Vorlesungen @@ -89,10 +89,10 @@ CourseNewDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display t CourseEditDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{csh} in diesem Semester. FFSheetName: Name TermCourseListHeading tid@TermId: Kursübersicht #{display tid} -TermSchoolCourseListHeading tid@TermId school@SchoolName: Kursübersicht #{display tid} für #{display school} +TermSchoolCourseListHeading tid@TermId school@SchoolName: Kursübersicht #{display tid} für #{school} CourseListTitle: Alle Kurse TermCourseListTitle tid@TermId: Kurse #{display tid} -TermSchoolCourseListTitle tid@TermId school@SchoolName: Kurse #{display tid} für #{display school} +TermSchoolCourseListTitle tid@TermId school@SchoolName: Kurse #{display tid} für #{school} CourseNewHeading: Neuen Kurs anlegen CourseEditHeading tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} editieren CourseEditTitle: Kurs editieren/anlegen @@ -142,7 +142,7 @@ CourseLecturerRightsIdentical: Alle Sorten von Kursverwalter haben identische Re NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht. NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht. -NoSuchCourseShorthand csh@CourseShorthand: Kein Kurs mit Kürzel #{display csh} bekannt. +NoSuchCourseShorthand csh@CourseShorthand: Kein Kurs mit Kürzel #{csh} bekannt. NoSuchCourse: Keinen passenden Kurs gefunden. Sheet: Blatt diff --git a/src/Foundation.hs b/src/Foundation.hs index 733a55a9f..7eaaeabba 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -2231,25 +2231,25 @@ pageActions (CSheetR tid ssh csh shn SCorrR) = ] pageActions (CorrectionsR) = [ MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuCorrectionsDownload - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute CorrectionsDownloadR - , menuItemModal = True + , menuItemModal = False , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuCorrectionsUpload - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute CorrectionsUploadR , menuItemModal = True , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuCorrectionsCreate - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute CorrectionsCreateR , menuItemModal = False , menuItemAccessCallback' = runDB . maybeT (return False) $ do diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 4a18d3b79..34530d0e8 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -502,7 +502,7 @@ postCorrectionsR = do let whereClause = ratedBy uid colonnade = mconcat [ colSelect - -- , dbRow + , dbRow -- very useful, since correction statistics are still missing. , colSchool , colTerm , colCourse diff --git a/src/Utils.hs b/src/Utils.hs index 1fb39b1b6..a66e0313a 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -249,8 +249,8 @@ class DisplayAble a where instance DisplayAble Text where display = id -instance DisplayAble String where - display = pack +-- instance DisplayAble String where +-- display = pack instance DisplayAble Int instance DisplayAble Int64 From 953f7af1228bb37f1235d97acd0eb956f2072014 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 16 May 2019 12:11:48 +0200 Subject: [PATCH 04/13] Avoid reported confusion of bookmark using users --- messages/uniworx/de.msg | 5 +++-- routes | 2 +- src/Foundation.hs | 4 +++- src/Handler/Sheet.hs | 35 ++++++++++++++++++++++++++--------- 4 files changed, 33 insertions(+), 13 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index ccd4eac45..83045e281 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -190,7 +190,8 @@ SheetErrVisibility: "Beginn Abgabezeitraum" muss nach "Sichbar für Teilnehmer a SheetErrDeadlineEarly: "Ende Abgabezeitraum" muss nach "Beginn Abzeitraum" liegen SheetErrHintEarly: Hinweise dürfen erst nach Beginn des Abgabezeitraums herausgegeben werden SheetErrSolutionEarly: Lösungen dürfen erst nach Ende der Abgabezeitraums herausgegeben werden - +SheetNoCurrent: Es gibt momentan kein aktives Übungsblatt. +SheetNoOldUnassigned: Alle Abgaben inaktiver Blätter sind bereits einen Korrektor zugeteilt. Deadline: Abgabe Done: Eingereicht @@ -794,7 +795,7 @@ MenuSheetEdit: Übungsblatt editieren MenuSheetDelete: Übungsblatt löschen MenuSheetClone: Als neues Übungsblatt klonen MenuCorrectionsUpload: Korrekturen hochladen -MenuCorrectionsDownload: Abgaben herunterladen +MenuCorrectionsDownload: Offene Abgaben herunterladen MenuCorrectionsCreate: Abgaben registrieren MenuCorrectionsGrade: Abgaben online korrigieren MenuAuthPreds: Authorisierungseinstellungen diff --git a/routes b/routes index 45fa74da5..d934bd8f6 100644 --- a/routes +++ b/routes @@ -95,7 +95,7 @@ /ex SheetListR GET !course-registered !materials !corrector /ex/new SheetNewR GET POST /ex/current SheetCurrentR GET !course-registered !materials !corrector - /ex/unassigned SheetOldUnassigned GET + /ex/unassigned SheetOldUnassignedR GET /ex/#SheetName SheetR: /show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor /edit SEditR GET POST diff --git a/src/Foundation.hs b/src/Foundation.hs index 7eaaeabba..48b5e033e 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1450,6 +1450,8 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben" , Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen" , Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh SheetNewR ) = return ("Neu", Just $ CourseR tid ssh csh SheetListR) + breadcrumb (CourseR tid ssh csh SheetCurrentR) = return ("Aktuelles Blatt", Just $ CourseR tid ssh csh SheetListR) + breadcrumb (CourseR tid ssh csh SheetOldUnassignedR) = return ("Offene Abgaben", Just $ CourseR tid ssh csh SheetListR) breadcrumb (CourseR tid ssh csh CCommR ) = return ("Kursmitteilung", Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh CTutorialListR) = return ("Tutorien", Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh CTutorialNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CTutorialListR) @@ -1949,7 +1951,7 @@ pageActions (CourseR tid ssh csh SheetListR) = { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSheetOldUnassigned , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetOldUnassigned + , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetOldUnassignedR , menuItemModal = False , menuItemAccessCallback' = runDB . maybeT (return False) $ do void . MaybeT $ sheetOldUnassigned tid ssh csh diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 754d27a95..c5c7fb45f 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -146,16 +146,33 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do getSheetCurrentR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getSheetCurrentR tid ssh csh = runDB $ do - let redi shn = redirectAccess $ CSheetR tid ssh csh shn SShowR - shn <- sheetCurrent tid ssh csh - maybe notFound redi shn +getSheetCurrentR tid ssh csh = do + mbShn <- runDB $ sheetCurrent tid ssh csh + case mbShn of + Just shn -> redirectAccess $ CSheetR tid ssh csh shn SShowR + Nothing -> do -- no current sheet exists + -- users should never see a link to this URL in this situation, + -- but we had confused users that used a bookmark instead. + let headingShort = [whamlet|_{MsgMenuSheetCurrent}|] + headingLong = prependCourseTitle tid ssh csh MsgMenuSheetCurrent + siteLayout headingShort $ do + setTitleI headingLong + [whamlet|_{MsgSheetNoCurrent}|] -getSheetOldUnassigned :: TermId -> SchoolId -> CourseShorthand -> Handler () -getSheetOldUnassigned tid ssh csh = runDB $ do - let redi shn = redirectAccess $ CSheetR tid ssh csh shn SSubsR - shn <- sheetOldUnassigned tid ssh csh - maybe notFound redi shn + +getSheetOldUnassignedR:: TermId -> SchoolId -> CourseShorthand -> Handler Html +getSheetOldUnassignedR tid ssh csh = do + mbShn <- runDB $ sheetOldUnassigned tid ssh csh + case mbShn of + Just shn -> redirectAccess $ CSheetR tid ssh csh shn SSubsR + Nothing -> do -- no unassigned submissions in any inactive sheet + -- users should never see a link to this URL in this situation, + -- but we had confused users that used a bookmark instead. + let headingShort = [whamlet|_{MsgMenuSheetOldUnassigned}|] + headingLong = prependCourseTitle tid ssh csh MsgMenuSheetOldUnassigned + siteLayout headingShort $ do + setTitleI headingLong + [whamlet|_{MsgSheetNoOldUnassigned}|] getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getSheetListR tid ssh csh = do From 86204f78e2391c32b2cf6c9716de6c9cb738168b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 16 May 2019 13:58:07 +0200 Subject: [PATCH 05/13] attempt at #374 failed --- src/Handler/Corrections.hs | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 34530d0e8..536ebb35a 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -200,6 +200,35 @@ colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ formCe (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment)) +colLastEdit :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData))) +colLastEdit = sortable (Just "last-edit") (i18nCell MsgLastEdit) $ + \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> sqlCell $ do + edits <- E.select $ E.from $ \edit -> do + E.where_ $ edit E.^. SubmissionEditSubmission E.==. E.val subId + return $ E.max_ $ edit E.^. SubmissionEditTime + return [whamlet| + $newline never + DATES + $forall ed <- edits + #{show ed} + |] + +-- colLastEdit' :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData))) +-- colLastEdit' = sortable (Just "last-edit") (i18nCell MsgLastEdit) $ (formCell id +-- (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) +-- (const mempty)) +-- -- \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> sqlCell $ do +-- -- edits <- E.select $ E.from $ \edit -> do +-- -- E.where_ $ edit E.^. SubmissionEditSubmission E.==. E.val subId +-- -- return $ E.max_ $ edit E.^. SubmissionEditTime +-- -- return [whamlet| +-- -- $newline never +-- -- DATES +-- -- $forall ed <- edits +-- -- #{show ed} +-- -- |] + + makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h ) => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> _ -> PSValidator m x -> _ -> DBParams m x -> DB (DBResult m x) @@ -551,6 +580,8 @@ postCCorrectionsR tid ssh csh = do , colSMatrikel , colSubmittors , colSubmissionLink + -- , colLastEdit -- this does not type + -- , colLastEdit' , colRating , colRated , colCorrector From 601cbeab7611b1a47741673594224946daea850b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 17 May 2019 13:40:39 +0200 Subject: [PATCH 06/13] Fixes #381 --- src/Handler/Utils.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index ed2334d5c..3f1bd2aae 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -54,8 +54,9 @@ serveOneFile query = do case results of [Entity _fileId File{fileTitle, fileContent}] | Just fileContent' <- fileContent -> do - whenM downloadFiles $ - addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|] + ifM downloadFiles + (addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]) + (addHeader "Content-Disposition" [st|inline; filename="#{takeFileName fileTitle}"|]) return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent') | otherwise -> sendResponseStatus noContent204 () [] -> notFound @@ -72,8 +73,9 @@ serveSomeFiles archiveName query = do [] -> notFound [Entity _fileId File{fileTitle, fileContent}] | Just fileContent' <- fileContent -> do - whenM downloadFiles $ - addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|] + ifM downloadFiles + (addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]) + (addHeader "Content-Disposition" [st|inline; filename="#{takeFileName fileTitle}"|]) return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent') | otherwise -> sendResponseStatus noContent204 () files -> do From c0bc4dd8f37b1574cc2e9b4941f709a59586ad16 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 17 May 2019 13:53:07 +0200 Subject: [PATCH 07/13] Code DRY cleaning --- src/Handler/Utils.hs | 33 ++++++++++++++++----------------- 1 file changed, 16 insertions(+), 17 deletions(-) diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 3f1bd2aae..a51723840 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -38,6 +38,7 @@ import qualified Data.List as List import qualified Data.List.NonEmpty as NonEmpty +-- | Check whether the user's preference for files is inline-viewing or downloading downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool downloadFiles = do mauth <- liftHandlerT maybeAuth @@ -47,18 +48,22 @@ downloadFiles = do UserDefaultConf{..} <- getsYesod $ view _appUserDefaults return userDefaultDownloadFiles +-- | Simply send a `File`-Value +sendThisFile :: File -> Handler TypedContent +sendThisFile File{..} + | Just fileContent' <- fileContent = do + ifM downloadFiles + (addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]) + (addHeader "Content-Disposition" [st|inline; filename="#{takeFileName fileTitle}"|]) + return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent') + | otherwise = sendResponseStatus noContent204 () + -- | Serve a single file, identified through a given DB query serveOneFile :: DB [Entity File] -> Handler TypedContent serveOneFile query = do results <- runDB query case results of - [Entity _fileId File{fileTitle, fileContent}] - | Just fileContent' <- fileContent -> do - ifM downloadFiles - (addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]) - (addHeader "Content-Disposition" [st|inline; filename="#{takeFileName fileTitle}"|]) - return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent') - | otherwise -> sendResponseStatus noContent204 () + [Entity _fileId file] -> sendThisFile file [] -> notFound other -> do $logErrorS "SFileR" $ "Multiple matching files: " <> tshow other @@ -70,19 +75,13 @@ serveSomeFiles :: Text -> DB [Entity File] -> Handler TypedContent serveSomeFiles archiveName query = do results <- runDB query case results of - [] -> notFound - [Entity _fileId File{fileTitle, fileContent}] - | Just fileContent' <- fileContent -> do - ifM downloadFiles - (addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]) - (addHeader "Content-Disposition" [st|inline; filename="#{takeFileName fileTitle}"|]) - return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent') - | otherwise -> sendResponseStatus noContent204 () - files -> do + [] -> notFound + [Entity _fileId file] -> sendThisFile file + moreFiles -> do addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece archiveName}"|] respondSourceDB "application/zip" $ do let zipComment = T.encodeUtf8 archiveName - yieldMany files .| Conduit.map entityVal .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder + yieldMany moreFiles .| Conduit.map entityVal .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder tidFromText :: Text -> Maybe TermId From e676be8f3f19403b8ca73d7ce454343bcc29d96f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 17 May 2019 18:51:55 +0200 Subject: [PATCH 08/13] Fixes #374 --- src/Handler/Corrections.hs | 108 ++++++++++++++++--------------------- 1 file changed, 47 insertions(+), 61 deletions(-) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 536ebb35a..33bcb4992 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -36,6 +36,7 @@ import Data.Monoid (All(..)) -- import qualified Data.Conduit.List as C import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Internal.Language (From) -- import qualified Database.Esqueleto.Internal.Sql as E -- import Control.Monad.Writer (MonadWriter(..), execWriterT) @@ -60,7 +61,7 @@ import Data.Foldable (foldrM) type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) type CorrectionTableWhere = CorrectionTableExpr -> E.SqlExpr (E.Value Bool) -type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId (User, Maybe Pseudonym)) +type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Maybe UTCTime, Map UserId (User, Maybe Pseudonym)) correctionsTableQuery :: CorrectionTableWhere -> (CorrectionTableExpr -> v) -> CorrectionTableExpr -> E.SqlQuery v correctionsTableQuery whereClause returnStatement t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do @@ -70,6 +71,12 @@ correctionsTableQuery whereClause returnStatement t@((course `E.InnerJoin` sheet E.where_ $ whereClause t return $ returnStatement t +lastEditQuery :: Database.Esqueleto.Internal.Language.From query expr backend (expr (Entity SubmissionEdit)) + => expr (Entity Submission) -> expr (E.Value (Maybe UTCTime)) +lastEditQuery submission = E.sub_select $ E.from $ \edit -> do + E.where_ $ edit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId + return $ E.max_ $ edit E.^. SubmissionEditTime + -- Where Clauses ratedBy :: UserId -> CorrectionTableWhere ratedBy uid ((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) @@ -84,40 +91,41 @@ sheetIs shid ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftO -- Columns colTerm :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colTerm = sortable (Just "term") (i18nCell MsgTerm) - $ \DBRow{ dbrOutput=(_, _, course, _, _) } -> - -- cell [whamlet| _{untermKey $ course ^. _3}|] -- lange, internationale Semester - textCell $ termToText $ unTermKey $ course ^. _3 -- kurze Semsterkürzel + $ \DBRow{ dbrOutput } -> + textCell $ termToText $ unTermKey $ dbrOutput ^. _3 . _3 -- kurze Semsterkürzel colSchool :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSchool = sortable (Just "school") (i18nCell MsgCourseSchool) - $ \DBRow{ dbrOutput=(_, _, course, _, _) } -> + $ \DBRow{ dbrOutput } -> let course = dbrOutput ^. _3 in anchorCell (TermSchoolCourseListR (course ^. _3) (course ^. _4)) [whamlet|#{unSchoolKey (course ^. _4)}|] colCourse :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colCourse = sortable (Just "course") (i18nCell MsgCourse) - $ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid), _, _) } -> courseCellCL (tid,sid,csh) + $ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid),_ , _, _) } -> courseCellCL (tid,sid,csh) colSheet :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colSheet = sortable (Just "sheet") (i18nCell MsgSheet) - $ \DBRow{ dbrOutput=(_, sheet, course, _, _) } -> - let tid = course ^. _3 +colSheet = sortable (Just "sheet") (i18nCell MsgSheet) $ \row -> + let sheet = row ^. _dbrOutput . _2 + course= row ^. _dbrOutput . _3 + tid = course ^. _3 ssh = course ^. _4 csh = course ^. _2 shn = sheetName $ entityVal sheet in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|#{display shn}|] colSheetType :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colSheetType = sortable (toNothing "sheetType") (i18nCell MsgSheetType) - $ \DBRow{ dbrOutput=(_, sheet, _, _, _) } -> i18nCell . sheetType $ entityVal sheet +colSheetType = sortable (toNothing "sheetType") (i18nCell MsgSheetType) $ + i18nCell . sheetType <$> view (_dbrOutput . _2 . _entityVal) + -- $ \DBRow{ dbrOutput=(_, sheet, _, _, _, _) } -> i18nCell . sheetType $ entityVal sheet colCorrector :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case - DBRow{ dbrOutput = (_, _, _, Nothing , _) } -> cell mempty - DBRow{ dbrOutput = (_, _, _, Just (Entity _ User{..}), _) } -> userCell userDisplayName userSurname + DBRow{ dbrOutput = (_, _, _, Nothing , _, _) } -> cell mempty + DBRow{ dbrOutput = (_, _, _, Just (Entity _ User{..}), _, _) } -> userCell userDisplayName userSurname colSubmissionLink :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSubmissionLink = sortable Nothing (i18nCell MsgSubmission) - $ \DBRow{ dbrOutput=(submission, sheet, course, _, _) } -> + $ \DBRow{ dbrOutput=(submission, sheet, course, _, _,_) } -> let csh = course ^. _2 tid = course ^. _3 ssh = course ^. _4 @@ -129,10 +137,10 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission) in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|]) colSelect :: forall act h. (Semigroup act, Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary)) -colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId +colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> encrypt subId colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, users) } -> let +colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, _, users) } -> let csh = course ^. _2 tid = course ^. _3 ssh = course ^. _4 @@ -144,12 +152,12 @@ colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DB in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let +colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, _, users) } -> let protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer) in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colRating :: forall m a. IsDBTable m (a, SheetTypeSummary) => Colonnade Sortable CorrectionTableData (DBCell m (a, SheetTypeSummary)) -colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId sub@Submission{..}, Entity _ Sheet{..}, course, _, _) } -> +colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId sub@Submission{..}, Entity _ Sheet{..}, course, _, _, _) } -> let csh = course ^. _2 tid = course ^. _3 ssh = course ^. _4 @@ -169,65 +177,40 @@ colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(E ] colAssigned :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _) } -> +colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _, _) } -> maybe mempty dateTimeCell submissionRatingAssigned colRated :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colRated = sortable (Just "ratingtime") (i18nCell MsgRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _) } -> +colRated = sortable (Just "ratingtime") (i18nCell MsgRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _, _) } -> maybe mempty dateTimeCell submissionRatingTime colPseudonyms :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let +colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_, _, _, _, _, users) } -> let lCell = listCell (catMaybes $ snd . snd <$> Map.toList users) $ \pseudo -> cell [whamlet|#{review _PseudonymText pseudo}|] in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colRatedField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (Bool, a, b) CorrectionTableData))) colRatedField = sortable Nothing (i18nCell MsgRatingDone) $ formCell id - (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) - (\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _) } mkUnique -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField (fsUniq mkUnique "rated") (Just done)) + (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId) + (\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _, _) } mkUnique -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField (fsUniq mkUnique "rated") (Just done)) colPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData))) colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id - (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) - (\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } mkUnique -> case sheetType of + (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId) + (\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _, _) } mkUnique -> case sheetType of NotGraded -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty) _other -> over (_1.mapped) (_2 .~) . over _2 fvInput <$> mopt pointsField (fsUniq mkUnique "points") (Just submissionRatingPoints) ) colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData))) colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ formCell id - (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) - (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment)) + (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId) + (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment)) -colLastEdit :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData))) +colLastEdit :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colLastEdit = sortable (Just "last-edit") (i18nCell MsgLastEdit) $ - \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> sqlCell $ do - edits <- E.select $ E.from $ \edit -> do - E.where_ $ edit E.^. SubmissionEditSubmission E.==. E.val subId - return $ E.max_ $ edit E.^. SubmissionEditTime - return [whamlet| - $newline never - DATES - $forall ed <- edits - #{show ed} - |] - --- colLastEdit' :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData))) --- colLastEdit' = sortable (Just "last-edit") (i18nCell MsgLastEdit) $ (formCell id --- (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) --- (const mempty)) --- -- \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> sqlCell $ do --- -- edits <- E.select $ E.from $ \edit -> do --- -- E.where_ $ edit E.^. SubmissionEditSubmission E.==. E.val subId --- -- return $ E.max_ $ edit E.^. SubmissionEditTime --- -- return [whamlet| --- -- $newline never --- -- DATES --- -- $forall ed <- edits --- -- #{show ed} --- -- |] - + \DBRow{ dbrOutput=(_, _, _, _, mbLastEdit, _) } -> maybe mempty dateTimeCell mbLastEdit makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h ) @@ -241,10 +224,10 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d , course E.^. CourseTerm , course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId) ) - in (submission, sheet, crse, corrector) + in (submission, sheet, crse, corrector, lastEditQuery submission) ) dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData - dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector) -> do + dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) -> do submittors <- lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId) E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId) @@ -254,7 +237,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d return (user, pseudonym E.?. SheetPseudonymPseudonym) let submittorMap = foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors - dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap) + dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap) dbTable psValidator DBTable { dbtSQLQuery , dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) -> submission E.^. SubmissionId @@ -300,6 +283,9 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d , ( "comment" -- sorting by comment specifically requested by correctors to easily see submissions to be done , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingComment ) + , ( "last-edit" + , SortColumn $ \((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) -> lastEditQuery submission + ) ] , dbtFilter = Map.fromList [ ( "term" @@ -580,8 +566,7 @@ postCCorrectionsR tid ssh csh = do , colSMatrikel , colSubmittors , colSubmissionLink - -- , colLastEdit -- this does not type - -- , colLastEdit' + , colLastEdit , colRating , colRated , colCorrector @@ -605,6 +590,7 @@ postSSubsR tid ssh csh shn = do , colSMatrikel , colSubmittors , colSubmissionLink + , colLastEdit , colRating , colRated , colCorrector @@ -928,8 +914,8 @@ postCorrectionsGradeR = do ] -- Continue here psValidator = def & defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData)) - unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment) - dbtProj' i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) = do + unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment) + dbtProj' i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _, _) = do cID <- encrypt subId void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True return i From 97eb18c5aac1e9f15ed7bccf313c11c21940ec0a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 18 May 2019 15:58:29 +0200 Subject: [PATCH 09/13] Cleanup file handling * Use serve*File(s)-Utilities wherever possible * Stream Files from database through zip-encoder and to client whenever possible * Get rid of ZIPArchiveName and use Content-Disposition everywhere * Make Content-Disposition able to deal with non-ascii filenames --- routes | 9 ++-- src/Foundation.hs | 8 ++-- src/Handler/Material.hs | 45 ++++++++------------ src/Handler/Sheet.hs | 10 ++--- src/Handler/Submission.hs | 86 ++++++++++++++++----------------------- src/Handler/Utils.hs | 43 ++++++++++++-------- src/Model/Types/Misc.hs | 10 ----- src/Utils.hs | 39 +++++++++++++++++- src/Utils/Sheet.hs | 10 ++--- 9 files changed, 134 insertions(+), 126 deletions(-) diff --git a/routes b/routes index d934bd8f6..40579f9e6 100644 --- a/routes +++ b/routes @@ -105,27 +105,26 @@ !/subs/own SubmissionOwnR GET !free -- just redirect /subs/#CryptoFileNameSubmission SubmissionR: / SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread - /archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner !corrector /delete SubDelR GET POST !ownerANDtime /assign SAssignR GET POST !lecturerANDtime /correction CorrectionR GET POST !corrector !ownerANDreadANDrated /invite SInviteR GET POST !ownerANDtime + !/#SubmissionFileType SubArchiveR GET !owner !corrector !/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector /correctors SCorrR GET POST /iscorrector SIsCorrR GET !corrector -- Route is used to check for corrector access to this sheet /pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions /corrector-invite/ SCorrInviteR GET POST + !/#SheetFileType SZipR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor !/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor - !/#{ZIPArchiveName SheetFileType} SZipR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor /file MaterialListR GET !course-registered !materials !corrector !tutor /file/new MaterialNewR GET POST /file/#MaterialName MaterialR: /edit MEditR GET POST /delete MDelR GET POST /show MShowR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor - /load/*FilePath MFileR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor - /download MArchiveR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor - /zip MZipR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor + !/download MArchiveR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor + !/download/*FilePath MFileR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor /tuts CTutorialListR GET !tutor -- THIS route is used to check for overall course tutor access! /tuts/new CTutorialNewR GET POST /tuts/#TutorialName TutorialR: diff --git a/src/Foundation.hs b/src/Foundation.hs index 48b5e033e..bf592b1b1 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -677,10 +677,10 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom SFileR _ _ -> mzero -- Archives of SheetFileType - SZipR (ZIPArchiveName SheetExercise) -> guard $ sheetActiveFrom <= cTime - SZipR (ZIPArchiveName SheetHint ) -> guard $ maybe False (<= cTime) sheetHintFrom - SZipR (ZIPArchiveName SheetSolution) -> guard $ maybe False (<= cTime) sheetSolutionFrom - SZipR _ -> mzero + SZipR SheetExercise -> guard $ sheetActiveFrom <= cTime + SZipR SheetHint -> guard $ maybe False (<= cTime) sheetHintFrom + SZipR SheetSolution -> guard $ maybe False (<= cTime) sheetSolutionFrom + SZipR _ -> mzero -- Submissions SubmissionNewR -> guard active SubmissionR _ SAssignR -> guard marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 7ae50af56..119fa5027 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -9,7 +9,7 @@ import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Conduit.List as C -- import qualified Data.CaseInsensitive as CI -import qualified Data.Text.Encoding as Text +-- import qualified Data.Text.Encoding as Text import qualified Database.Esqueleto as E import Database.Esqueleto.Utils.TH @@ -107,15 +107,18 @@ getMaterialListR tid ssh csh = do seeAllModificationTimestamps <- hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- ordinary users should not see modification dates older than visibility table <- runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - let row2material = entityVal . dbrOutput -- no inner join, just Entity Material + let row2material = view $ _dbrOutput . _1 . _entityVal psValidator = def & defaultSorting [SortDescBy "last-edit"] dbTableWidget' psValidator DBTable { dbtIdent = "material-list" :: Text , dbtStyle = def , dbtParams = def , dbtSQLQuery = \material -> do - E.where_ $ material E.^. MaterialCourse E.==. E.val cid - return material + E.where_ $ material E.^. MaterialCourse E.==. E.val cid + let filesNum = E.sub_select . E.from $ \materialFile -> do + E.where_ $ materialFile E.^. MaterialFileMaterial E.==. material E.^. MaterialId + return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int64)) + return (material, filesNum) , dbtRowKey = (E.^. MaterialId) -- , dbtProj = \dbr -> guardAuthorizedFor (matLink . materialName $ dbr ^. _dbrOutput . _entityVal) dbr , dbtProj = guardAuthorizedFor =<< matLink . materialName . row2material -- Moand: (a ->) @@ -127,8 +130,10 @@ getMaterialListR tid ssh csh = do $ liftA2 anchorCell matLink toWgt . materialName . row2material , sortable (toNothingS "description") mempty $ foldMap modalCell . materialDescription . row2material - , sortable (toNothingS "zip-archive") mempty -- TODO: don't show if there are no files! - $ fileCell . filesLink . materialName . row2material + , sortable (toNothingS "zip-archive") mempty + $ \DBRow{ dbrOutput = (Entity _ Material{..}, E.Value fileNum) } -> if + | fileNum == 0 -> mempty + | otherwise -> fileCell $ filesLink materialName , sortable (Just "visible-from") (i18nCell MsgAccessibleSince) $ foldMap (dateTimeCellVisible now) . materialVisibleFrom . row2material , sortable (Just "last-edit") (i18nCell MsgFileModified) @@ -156,9 +161,9 @@ getMaterialListR tid ssh csh = do getMFileR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> FilePath -> Handler TypedContent -getMFileR tid ssh csh mnm title = serveOneFile fileQuery +getMFileR tid ssh csh mnm title = serveOneFile $ fileQuery .| C.map entityVal where - fileQuery = E.select $ E.from $ + fileQuery = E.selectSource $ E.from $ \(course `E.InnerJoin` material `E.InnerJoin` matFile `E.InnerJoin` file) -> do -- Restrict to consistent rows that correspond to each other E.on (file E.^. FileId E.==. matFile E.^. MaterialFileFile) @@ -180,7 +185,7 @@ getMShowR tid ssh csh mnm = do matLink = CourseR tid ssh csh . MaterialR mnm . MFileR zipLink :: Route UniWorX - zipLink = CMaterialR tid ssh csh mnm MZipR + zipLink = CMaterialR tid ssh csh mnm MArchiveR seeAllModificationTimestamps <- hasReadAccessTo $ CourseR tid ssh csh CNotesR -- ordinary users should not see modification dates older than visibility @@ -351,28 +356,12 @@ postMDelR tid ssh csh mnm = do , drAbort = SomeRoute $ CourseR tid ssh csh $ MaterialR mnm MShowR } --- | Variant of getMArchiveR that always serves a Zip Archive, even for single files. Kept, since we might change this according to UX feedback. -getMZipR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler TypedContent -getMZipR tid ssh csh mnm = do - let filename = ZIPArchiveName mnm - addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|] - respondSourceDB "application/zip" $ do - mid <- lift $ getMaterialKeyBy404 tid ssh csh mnm - -- Entity{entityKey=mid, entityVal=material} <- lift $ fetchMaterial tid ssh csh mnm - let - fileSelect = E.selectSource . E.from $ \(materialFile `E.InnerJoin` file) -> do - E.on $ materialFile E.^. MaterialFileFile E.==. file E.^. FileId - E.where_ $ materialFile E.^. MaterialFileMaterial E.==. E.val mid - return file - zipComment = Text.encodeUtf8 $ termToText (unTermKey tid) <> "-" <> toPathPiece (unSchoolKey ssh <> "-" <> csh <> ":" <> mnm) - fileSelect .| C.map entityVal .| produceZip ZipInfo{..} .| C.map toFlushBuilder - --- | Variant of getMZipR that does not serve single file Zip Archives. Maybe confusing to users. +-- | Serve all material-files getMArchiveR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler TypedContent getMArchiveR tid ssh csh mnm = serveSomeFiles archivename getMatQuery where - archivename = termToText (unTermKey tid) <> "-" <> toPathPiece (unSchoolKey ssh <> "-" <> csh <> "-" <> mnm) - getMatQuery = E.select . E.from $ + archivename = unpack (termToText (unTermKey tid) <> "-" <> toPathPiece (unSchoolKey ssh <> "-" <> csh <> "-" <> mnm)) <.> "zip" + getMatQuery = (.| C.map entityVal) . E.selectSource . E.from $ \(course `E.InnerJoin` material `E.InnerJoin` materialFile `E.InnerJoin` file) -> do E.on $ file E.^. FileId E.==. materialFile E.^. MaterialFileFile E.on $ material E.^. MaterialId E.==. materialFile E.^. MaterialFileMaterial diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index c5c7fb45f..88af1d515 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -215,7 +215,7 @@ getSheetListR tid ssh csh = do [ icnCell & addIconFixedWidth | let existingSFTs = hasSFT existFiles , sft <- [minBound..maxBound] - , let link = CSheetR tid ssh csh sheetName $ SZipR $ ZIPArchiveName sft + , let link = CSheetR tid ssh csh sheetName $ SZipR sft , let icn = toWidget $ sheetFile2markup sft , let icnCell = if sft `elem` existingSFTs then linkEmptyCell link icn @@ -455,11 +455,11 @@ postSPseudonymR tid ssh csh shn = do getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent -getSFileR tid ssh csh shn sft file = serveOneFile $ sheetFileQuery tid ssh csh shn sft file +getSFileR tid ssh csh shn sft file = serveOneFile $ sheetFileQuery tid ssh csh shn sft file .| C.map entityVal -getSZipR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> ZIPArchiveName SheetFileType -> Handler TypedContent -getSZipR tid ssh csh shn filename@(ZIPArchiveName sft) - = serveSomeFiles (toPathPiece filename) $ sheetFilesAllQuery tid ssh csh shn sft +getSZipR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> Handler TypedContent +getSZipR tid ssh csh shn sft + = serveSomeFiles (unpack (toPathPiece sft) <.> "zip") $ sheetFilesAllQuery tid ssh csh shn sft .| C.map entityVal getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 3e31fb658..f9f04f8cc 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -38,8 +38,6 @@ import Data.Map (Map, (!), (!?)) import qualified Data.Map as Map -- import Data.Bifunctor -import System.FilePath - import Text.Blaze (Markup) import Data.Aeson hiding (Result(..)) import Text.Hamlet (ihamlet) @@ -515,8 +513,8 @@ submissionHelper tid ssh csh shn mcid = do defaultLayout $ do setTitleI $ MsgSubmissionEditHead tid ssh csh shn - let urlArchive cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionCorrected)) - urlOriginal cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal)) + let urlArchive cID = CSubmissionR tid ssh csh shn cID $ SubArchiveR SubmissionCorrected + urlOriginal cID = CSubmissionR tid ssh csh shn cID $ SubArchiveR SubmissionOriginal $(widgetFile "submission") getSInviteR, postSInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html @@ -525,72 +523,60 @@ postSInviteR = invitationR submissionUserInvitationConfig getSubDownloadR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent -getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = runDB $ do - submissionID <- submissionMatchesSheet tid ssh csh shn cID +getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do + (submissionID, isRating) <- runDB $ do + submissionID <- submissionMatchesSheet tid ssh csh shn cID - isRating <- (== Just submissionID) <$> isRatingFile path + isRating <- (== Just submissionID) <$> isRatingFile path - when (isUpdate || isRating) $ - guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False + when (isUpdate || isRating) $ + guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False + + return (submissionID, isRating) case isRating of True - | isUpdate -> do + | isUpdate -> runDB $ do file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID) maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file | otherwise -> notFound False -> do - results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do - E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile) - E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID - E.&&. f E.^. FileTitle E.==. E.val path - E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion) - E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate - -- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204 - return f + let results = (.| Conduit.map entityVal) . E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do + E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile) + E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID + E.&&. f E.^. FileTitle E.==. E.val path + E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion) + E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate + -- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204 + return f - case results of - [] -> notFound - [Entity _ File{ fileContent = Just c, fileTitle }] -> do - whenM downloadFiles $ - addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|] - return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c) - [Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 () - other -> do - $logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other - error "Multiple matching files found." + serveOneFile results -getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent -getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do +getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> Handler TypedContent +getSubArchiveR tid ssh csh shn cID sfType = do when (sfType == SubmissionCorrected) $ guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False let filename - | SubmissionOriginal <- sfType = ZIPArchiveName $ toPathPiece cID <> "-" <> toPathPiece sfType - | otherwise = ZIPArchiveName $ toPathPiece cID + | SubmissionOriginal <- sfType = toPathPiece cID <> "-" <> toPathPiece sfType + | otherwise = toPathPiece cID - addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|] - respondSourceDB "application/zip" $ do - submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID - rating <- lift $ getRating submissionID + source = do + submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID + rating <- lift $ getRating submissionID - let - fileSelect = case sfType of - SubmissionOriginal -> E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do - E.on $ f E.^. FileId E.==. sf E.^. SubmissionFileFile - E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID - E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val False - return f - _ -> submissionFileSource submissionID + case sfType of + SubmissionOriginal -> (.| Conduit.map entityVal) . E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do + E.on $ f E.^. FileId E.==. sf E.^. SubmissionFileFile + E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID + E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val False + return f + _ -> submissionFileSource submissionID .| Conduit.map entityVal - fileSource' = do - fileSelect .| Conduit.map entityVal when (sfType == SubmissionCorrected) $ maybe (return ()) (yieldM . ratingFile cID) rating - zipComment = Text.encodeUtf8 $ toPathPiece cID - - fileSource' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder + serveSomeFiles (unpack filename <.> "zip") source getSubDelR, postSubDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html getSubDelR = postSubDelR @@ -612,4 +598,4 @@ getCorrectionsDownloadR = do -- download all assigned and open submissions when (null subs) $ do addMessageI Info MsgNoOpenSubmissions redirect CorrectionsR - submissionMultiArchive $ Set.fromList subs \ No newline at end of file + submissionMultiArchive $ Set.fromList subs diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index a51723840..e1aea383f 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -48,40 +48,47 @@ downloadFiles = do UserDefaultConf{..} <- getsYesod $ view _appUserDefaults return userDefaultDownloadFiles +setContentDisposition' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Maybe FilePath -> m () +setContentDisposition' mFileName = do + wantsDownload <- downloadFiles + setContentDisposition (bool ContentInline ContentAttachment wantsDownload) mFileName + -- | Simply send a `File`-Value sendThisFile :: File -> Handler TypedContent sendThisFile File{..} | Just fileContent' <- fileContent = do - ifM downloadFiles - (addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]) - (addHeader "Content-Disposition" [st|inline; filename="#{takeFileName fileTitle}"|]) + setContentDisposition' . Just $ takeFileName fileTitle return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent') | otherwise = sendResponseStatus noContent204 () -- | Serve a single file, identified through a given DB query -serveOneFile :: DB [Entity File] -> Handler TypedContent -serveOneFile query = do - results <- runDB query +serveOneFile :: Source (YesodDB UniWorX) File -> Handler TypedContent +serveOneFile source = do + results <- runDB . runConduit $ source .| Conduit.take 2 -- We don't need more than two files to make a decision below case results of - [Entity _fileId file] -> sendThisFile file - [] -> notFound - other -> do + [file] -> sendThisFile file + [] -> notFound + other -> do $logErrorS "SFileR" $ "Multiple matching files: " <> tshow other error "Multiple matching files found." -- | Serve one file directly or a zip-archive of files, identified through a given DB query +-- -- Like `serveOneFile`, but sends a zip-archive if multiple results are returned -serveSomeFiles :: Text -> DB [Entity File] -> Handler TypedContent -serveSomeFiles archiveName query = do - results <- runDB query +serveSomeFiles :: FilePath -> Source (YesodDB UniWorX) File -> Handler TypedContent +serveSomeFiles archiveName source = do + results <- runDB . runConduit $ source .| peekN 2 + + $logDebugS "serveSomeFiles" . tshow $ length results + case results of - [] -> notFound - [Entity _fileId file] -> sendThisFile file - moreFiles -> do - addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece archiveName}"|] + [] -> notFound + [file] -> sendThisFile file + _moreFiles -> do + setContentDisposition' $ Just archiveName respondSourceDB "application/zip" $ do - let zipComment = T.encodeUtf8 archiveName - yieldMany moreFiles .| Conduit.map entityVal .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder + let zipComment = T.encodeUtf8 $ pack archiveName + source .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder tidFromText :: Text -> Maybe TermId diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index 0affd8b70..aa3811f9d 100644 --- a/src/Model/Types/Misc.hs +++ b/src/Model/Types/Misc.hs @@ -18,13 +18,11 @@ import Data.Universe.Helpers import qualified Data.Text as Text import qualified Data.Text.Lens as Text -import qualified Data.CaseInsensitive as CI import Data.CaseInsensitive.Instances () import Database.Persist.TH hiding (derivePersistFieldJSON) import Model.Types.JSON -import Yesod.Core.Dispatch (PathPiece(..)) import Data.Aeson (Value()) import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..)) @@ -71,14 +69,6 @@ $(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " derivePersistField "Theme" -newtype ZIPArchiveName obj = ZIPArchiveName { unZIPArchiveName :: obj } - deriving (Show, Read, Eq, Ord, Generic, Typeable) - -instance PathPiece obj => PathPiece (ZIPArchiveName obj) where - fromPathPiece = fmap ZIPArchiveName . fromPathPiece <=< (stripSuffix `on` CI.foldCase) ".zip" - toPathPiece = (<> ".zip") . toPathPiece . unZIPArchiveName - - data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) diff --git a/src/Utils.hs b/src/Utils.hs index a66e0313a..4f9d28a25 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -30,7 +30,7 @@ import Utils.Parameters as Utils import Text.Blaze (Markup, ToMarkup) -import Data.Char (isDigit, isSpace) +import Data.Char (isDigit, isSpace, isAscii) import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight) import Numeric (showFFloat) @@ -718,6 +718,16 @@ mconcatForM = flip mconcatMapM findM :: (Monad m, Foldable f) => (a -> MaybeT m b) -> f a -> m (Maybe b) findM f = runMaybeT . Fold.foldr (\x as -> f x <|> as) mzero +------------- +-- Conduit -- +------------- + +peekN :: (Integral n, Monad m) => n -> Consumer a m [a] +peekN n = do + peeked <- catMaybes <$> replicateM (fromIntegral n) await + mapM_ leftover peeked + return peeked + ----------------- -- Alternative -- ----------------- @@ -781,6 +791,33 @@ addCustomHeader, replaceOrAddCustomHeader :: (MonadHandler m, PathPiece payload) addCustomHeader ident payload = addHeader (toPathPiece ident) (toPathPiece payload) replaceOrAddCustomHeader ident payload = replaceOrAddHeader (toPathPiece ident) (toPathPiece payload) +------------------ +-- HTTP Headers -- +------------------ + +data ContentDisposition = ContentInline | ContentAttachment + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe ContentDisposition +instance Finite ContentDisposition +nullaryPathPiece ''ContentDisposition $ camelToPathPiece' 1 + +setContentDisposition :: MonadHandler m => ContentDisposition -> Maybe FilePath -> m () +-- ^ Set a @Content-Disposition@-header using `replaceOrAddHeader` +-- +-- Takes care of correct formatting and encoding of non-ascii filenames +setContentDisposition cd (fmap pack -> mFName) = replaceOrAddHeader "Content-Disposition" headerVal + where + headerVal + | Just fName <- mFName + , Text.all isAscii fName + , Text.all (not . flip elem ['"', '\\']) fName + = [st|#{toPathPiece cd}; filename="#{fName}"|] + | Just fName <- mFName + = let encoded = decodeUtf8 . urlEncode True $ encodeUtf8 fName + in [st|#{toPathPiece cd}; filename*=UTF-8''#{encoded}|] + | otherwise + = toPathPiece cd + ------------------ -- Cryptography -- ------------------ diff --git a/src/Utils/Sheet.hs b/src/Utils/Sheet.hs index d2f0cf11e..0fa7da74f 100644 --- a/src/Utils/Sheet.hs +++ b/src/Utils/Sheet.hs @@ -47,8 +47,8 @@ sheetOldUnassigned tid ssh csh = do _ -> error "SQL Query with limit 1 returned more than one result" -- | Return a specfic file from a `Sheet` -sheetFileQuery :: MonadIO m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> SqlReadT m [Entity File] -sheetFileQuery tid ssh csh shn sft title = E.select $ E.from $ +sheetFileQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Source (SqlPersistT m) (Entity File) +sheetFileQuery tid ssh csh shn sft title = E.selectSource $ E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sFile `E.InnerJoin` file) -> do -- Restrict to consistent rows that correspond to each other E.on (file E.^. FileId E.==. sFile E.^. SheetFileFile) @@ -66,8 +66,8 @@ sheetFileQuery tid ssh csh shn sft title = E.select $ E.from $ return file -- | Return all files of a certain `SheetFileType` for a `Sheet` -sheetFilesAllQuery :: MonadIO m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> SqlReadT m [Entity File] -sheetFilesAllQuery tid ssh csh shn sft = E.select $ E.from $ +sheetFilesAllQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> Source (SqlPersistT m) (Entity File) +sheetFilesAllQuery tid ssh csh shn sft = E.selectSource $ E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sFile `E.InnerJoin` file) -> do -- Restrict to consistent rows that correspond to each other E.on (file E.^. FileId E.==. sFile E.^. SheetFileFile) @@ -89,4 +89,4 @@ hasSheetFileQuery :: Database.Esqueleto.Internal.Language.From query expr backen hasSheetFileQuery sheet sft = E.exists $ E.from $ \sFile -> E.where_ ((sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) - E.&&. (sFile E.^. SheetFileType E.==. E.val sft )) \ No newline at end of file + E.&&. (sFile E.^. SheetFileType E.==. E.val sft )) From 9f101087ac50df134a12a1a284db619815e92f3c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 18 May 2019 22:51:07 +0200 Subject: [PATCH 10/13] Overhaul SubmissonMode extensively --- config/archive-types | 40 +++++ messages/uniworx/de.msg | 21 ++- routes | 6 +- src/Foundation.hs | 10 +- src/Handler/Admin.hs | 7 +- src/Handler/Corrections.hs | 4 +- src/Handler/Course.hs | 1 - src/Handler/Sheet.hs | 3 +- src/Handler/Submission.hs | 20 ++- src/Handler/Term.hs | 1 - src/Handler/Tutorial.hs | 1 - src/Handler/Utils/Communication.hs | 1 - src/Handler/Utils/Form.hs | 144 ++++++++++++++---- src/Handler/Utils/Form/MassInput.hs | 1 - src/Handler/Utils/Form/Occurences.hs | 1 - src/Handler/Utils/Submission.hs | 26 +++- src/Import/NoFoundation.hs | 2 + src/Model/Migration.hs | 4 +- src/Model/Submission.hs | 1 + src/Model/Types/Sheet.hs | 77 +++++----- src/Network/Mime/TH.hs | 14 +- src/Settings.hs | 14 +- src/Utils/Form.hs | 24 +++ src/Utils/Lens.hs | 2 + stack.yaml | 2 + .../messages/submissionFilesIgnored.hamlet | 2 +- .../massinput/uploadSpecificFiles/add.hamlet | 4 + .../massinput/uploadSpecificFiles/form.hamlet | 4 + .../uploadSpecificFiles/layout.hamlet | 16 ++ templates/widgets/specificFileField.hamlet | 8 + templates/widgets/zipFileField.hamlet | 8 +- test/Database.hs | 62 +++++++- 32 files changed, 422 insertions(+), 109 deletions(-) create mode 100644 config/archive-types create mode 100644 templates/widgets/massinput/uploadSpecificFiles/add.hamlet create mode 100644 templates/widgets/massinput/uploadSpecificFiles/form.hamlet create mode 100644 templates/widgets/massinput/uploadSpecificFiles/layout.hamlet create mode 100644 templates/widgets/specificFileField.hamlet diff --git a/config/archive-types b/config/archive-types new file mode 100644 index 000000000..0599971bb --- /dev/null +++ b/config/archive-types @@ -0,0 +1,40 @@ +# Simple list of mime-types corresponding to archive-formats +# +# Comments are empty lines and any line for which the first non-whitespace symbol is ‘#’ +# +# Format is a single mime-type per line (may not contain whitespace) +# +# Largely copied from https://en.wikipedia.org/wiki/List_of_archive_formats + +application/x-archive +application/x-cpio +application/x-bcpio +application/x-shar +application/x-iso9660-image +application/x-sbx +application/x-tar +application/x-7z-compressed +application/x-ace-compressed +application/x-astrotite-afa +application/x-alz-compressed +application/vnd.android.package-archive +application/x-arj +application/x-b1 +application/vnd.ms-cab-compressed +application/x-cfs-compressed +application/x-dar +application/x-dgc-compressed +application/x-apple-diskimage +application/x-gca-compressed +application/java-archive +application/x-lzh +application/x-lzx +application/x-rar-compressed +application/x-stuffit +application/x-stuffitx +application/x-gtar +application/x-ms-wim +application/x-xar +application/zip +application/x-zoo +application/x-par2 \ No newline at end of file diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 83045e281..9ea58fd65 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -445,6 +445,7 @@ SubmissionSinkExceptionDuplicateFileTitle file@FilePath: Dateiname #{show file} SubmissionSinkExceptionDuplicateRating: Mehr als eine Bewertung gefunden. SubmissionSinkExceptionRatingWithoutUpdate: Bewertung gefunden, es ist hier aber keine Bewertung der Abgabe möglich. SubmissionSinkExceptionForeignRating smid@CryptoFileNameSubmission: Fremde Bewertung für Abgabe #{toPathPiece smid} enthalten. Bewertungen müssen sich immer auf die gleiche Abgabe beziehen! +SubmissionSinkExceptionInvalidFileTitleExtension file@FilePath: Dateiname #{show file} hat keine der für dieses Übungsblatt zulässigen Dateiendungen. MultiSinkException name@Text error@Text: In Abgabe #{name} ist ein Fehler aufgetreten: #{error} @@ -488,7 +489,7 @@ LastEdit: Letzte Änderung LastEditByUser: Ihre letzte Bearbeitung NoEditByUser: Nicht von Ihnen bearbeitet -SubmissionFilesIgnored: Es wurden Dateien in der hochgeladenen Abgabe ignoriert: +SubmissionFilesIgnored n@Int: Es #{pluralDE n "wurde" "wurden"} #{tshow n} #{pluralDE n "Datei" "Dateien"} in der hochgeladenen Abgabe ignoriert SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe mit Nummer #{toPathPiece smid}. LDAPLoginTitle: Campus-Login @@ -507,8 +508,22 @@ DayIsOutOfLecture tid@TermId date@Text: #{date} ist außerhalb der Vorlesungszei DayIsOutOfTerm tid@TermId date@Text: #{date} liegt nicht im #{display tid} UploadModeNone: Kein Upload -UploadModeUnpack: Upload, einzelne Datei -UploadModeNoUnpack: Upload, ZIP-Archive entpacken +UploadModeAny: Upload, beliebige Datei(en) +UploadModeSpecific: Upload, vorgegebene Dateinamen + +UploadModeUnpackZips: Abgabe mehrerer Dateien +UploadModeUnpackZipsTip: Wenn die Abgabe mehrerer Dateien erlaubt ist, werden auch unterstützte Archiv-Formate zugelassen. Diese werden nach dann beim Hochladen automatisch entpackt. + +UploadModeExtensionRestriction: Zulässige Dateiendungen +UploadModeExtensionRestrictionTip: Komma-separiert. Wenn keine Dateiendungen angegeben werden erfolgt keine Einschränkung. + +UploadSpecificFiles: Vorgegebene Dateinamen +NoUploadSpecificFilesConfigured: Wenn der Abgabemodus vorgegebene Dateinamen vorsieht, muss mindestens ein vorgegebener Dateiname konfiguriert werden. +UploadSpecificFilesDuplicateNames: Vorgegebene Dateinamen müssen eindeutig sein +UploadSpecificFilesDuplicateLabels: Bezeichner für vorgegebene Dateinamen müssen eindeutig sein +UploadSpecificFileLabel: Bezeichnung +UploadSpecificFileName: Dateiname +UploadSpecificFileRequired: Zur Abgabe erforderlich NoSubmissions: Keine Abgabe CorrectorSubmissions: Abgabe extern mit Pseudonym diff --git a/routes b/routes index 40579f9e6..b1a1214bc 100644 --- a/routes +++ b/routes @@ -104,11 +104,11 @@ !/subs/new SubmissionNewR GET POST !timeANDcourse-registeredANDuser-submissions !/subs/own SubmissionOwnR GET !free -- just redirect /subs/#CryptoFileNameSubmission SubmissionR: - / SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread - /delete SubDelR GET POST !ownerANDtime + / SubShowR GET POST !ownerANDtimeANDuser-submissions !ownerANDread !correctorANDread + /delete SubDelR GET POST !ownerANDtimeANDuser-submissions /assign SAssignR GET POST !lecturerANDtime /correction CorrectionR GET POST !corrector !ownerANDreadANDrated - /invite SInviteR GET POST !ownerANDtime + /invite SInviteR GET POST !ownerANDtimeANDuser-submissions !/#SubmissionFileType SubArchiveR GET !owner !corrector !/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector /correctors SCorrR GET POST diff --git a/src/Foundation.hs b/src/Foundation.hs index bf592b1b1..b1a1f6b97 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -280,18 +280,12 @@ embedRenderMessage ''UniWorX ''SubmissionModeDescr verbMap [_, _, v] = v <> "Submissions" verbMap _ = error "Invalid number of verbs" in verbMap . splitCamel +embedRenderMessage ''UniWorX ''UploadModeDescr id +embedRenderMessage ''UniWorX ''SecretJSONFieldException id newtype SheetTypeHeader = SheetTypeHeader SheetType embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>) -instance RenderMessage UniWorX UploadMode where - renderMessage foundation ls uploadMode = case uploadMode of - NoUpload -> mr MsgUploadModeNone - Upload False -> mr MsgUploadModeNoUnpack - Upload True -> mr MsgUploadModeUnpack - where - mr = renderMessage foundation ls - instance RenderMessage UniWorX SheetType where renderMessage foundation ls sheetType = case sheetType of NotGraded -> mr $ SheetTypeHeader NotGraded diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 7a7cc36f8..6f13dba0c 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -2,7 +2,6 @@ module Handler.Admin where import Import import Handler.Utils -import Handler.Utils.Form.MassInput import Jobs import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder) @@ -261,7 +260,11 @@ postAdminErrMsgR = do [whamlet| $maybe t <- plaintext 
-          #{encodePrettyToTextBuilder t}
+          $case t
+            $of String t'
+              #{t'}
+            $of t'
+              #{encodePrettyToTextBuilder t'}
 
       ^{ctView'}
     |]
diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index 33bcb4992..bb547e7f7 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -644,7 +644,7 @@ postCorrectionR tid ssh csh shn cid = do
             }
 
       ((uploadResult, uploadForm'), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionUpload . renderAForm FormStandard $
-            areq (zipFileField True) (fslI MsgRatingFiles) Nothing
+            areq (zipFileField True Nothing) (fslI MsgRatingFiles) Nothing
       let uploadForm = wrapForm uploadForm' def
             { formAction = Just . SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR
             , formEncoding = uploadEncoding
@@ -720,7 +720,7 @@ getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html
 getCorrectionsUploadR = postCorrectionsUploadR
 postCorrectionsUploadR = do
   ((uploadRes, upload), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionsUpload . renderAForm FormStandard $
-       areq (zipFileField True) (fslI MsgCorrUploadField & addAttr "uw-file-input" "") Nothing
+       areq (zipFileField True Nothing) (fslI MsgCorrUploadField) Nothing
 
   case uploadRes of
     FormMissing -> return ()
diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs
index a274dbd92..5abd1e624 100644
--- a/src/Handler/Course.hs
+++ b/src/Handler/Course.hs
@@ -11,7 +11,6 @@ import Handler.Utils
 import Handler.Utils.Course
 import Handler.Utils.Tutorial
 import Handler.Utils.Communication
-import Handler.Utils.Form.MassInput
 import Handler.Utils.Delete
 import Handler.Utils.Database
 import Handler.Utils.Table.Cells
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index 88af1d515..0b0b62e40 100644
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@@ -14,7 +14,6 @@ import Handler.Utils.Table.Cells
 -- import Handler.Utils.Table.Columns
 import Handler.Utils.SheetType
 import Handler.Utils.Delete
-import Handler.Utils.Form.MassInput
 import Handler.Utils.Invitations
 
 -- import Data.Time
@@ -116,7 +115,7 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
             & setTooltip MsgSheetActiveFromTip)
                                                               (sfActiveFrom   <$> template)
       <*> areq utcTimeField   (fslI MsgSheetActiveTo)         (sfActiveTo     <$> template)
-      <*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ Upload True))
+      <*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction))
       <*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
       <*> aopt utcTimeField   (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren"
             & setTooltip MsgSheetHintFromTip)                 (sfHintFrom     <$> template)
diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs
index f9f04f8cc..12c605917 100644
--- a/src/Handler/Submission.hs
+++ b/src/Handler/Submission.hs
@@ -14,7 +14,6 @@ import Handler.Utils
 import Handler.Utils.Delete
 import Handler.Utils.Submission
 import Handler.Utils.Table.Cells
-import Handler.Utils.Form.MassInput
 import Handler.Utils.Invitations
 
 -- import Control.Monad.Trans.Maybe
@@ -130,8 +129,19 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
     fileUploadForm = case uploadMode of
       NoUpload
         -> pure Nothing
-      (Upload unpackZips)
-        -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
+      UploadAny{..}
+        -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips extensionRestriction) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
+      UploadSpecific{..}
+        -> mergeFileSources <$> sequenceA (map specificFileForm . Set.toList $ toNullable specificFiles)
+
+    specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe (Source Handler File))
+    specificFileForm spec@UploadSpecificFile{..}
+      = bool (\f fs d -> aopt f fs $ fmap Just d) (\f fs d -> Just <$> areq f fs d) specificFileRequired (specificFileField spec) (fsl specificFileLabel) Nothing
+
+    mergeFileSources :: [Maybe (Source Handler File)] -> Maybe (Source Handler File)
+    mergeFileSources (catMaybes -> sources) = case sources of
+      [] -> Nothing
+      fs -> Just $ sequence_ fs
 
     miCell' :: Markup -> Either UserEmail UserId -> Widget
     miCell' csrf (Left email) = $(widgetFile "widgets/massinput/submissionUsers/cellInvitation")
@@ -352,7 +362,9 @@ submissionHelper tid ssh csh shn mcid = do
               return (userName, submissionEdit E.^. SubmissionEditTime)
             forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
         return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner)
-  ((res,formWidget'), formEnctype) <- runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (Upload True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (Set.insert $ Right uid) isOwner buddies
+  -- @submissionModeUser == Nothing@ below iff we are currently serving a user with elevated rights (lecturer, admin, ...)
+  -- Therefore we do not restrict upload behaviour in any way in that case
+  ((res,formWidget'), formEnctype) <- runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (UploadAny True Nothing) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (Set.insert $ Right uid) isOwner buddies 
   let formWidget = wrapForm' BtnHandIn formWidget' def
         { formAction = Just $ SomeRoute actionUrl
         , formEncoding = formEnctype
diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs
index 08e960581..c25ec43bb 100644
--- a/src/Handler/Term.hs
+++ b/src/Handler/Term.hs
@@ -3,7 +3,6 @@ module Handler.Term where
 import Import
 import Handler.Utils
 import Handler.Utils.Table.Cells
-import Handler.Utils.Form.MassInput
 import qualified Data.Map as Map
 
 import Utils.Lens
diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs
index 534c7d1c1..2a98110c1 100644
--- a/src/Handler/Tutorial.hs
+++ b/src/Handler/Tutorial.hs
@@ -8,7 +8,6 @@ import Handler.Utils.Tutorial
 import Handler.Utils.Table.Cells
 import Handler.Utils.Delete
 import Handler.Utils.Communication
-import Handler.Utils.Form.MassInput
 import Handler.Utils.Form.Occurences
 import Handler.Utils.Invitations
 import Jobs.Queue
diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs
index 843160372..042e90a52 100644
--- a/src/Handler/Utils/Communication.hs
+++ b/src/Handler/Utils/Communication.hs
@@ -9,7 +9,6 @@ module Handler.Utils.Communication
 
 import Import
 import Handler.Utils
-import Handler.Utils.Form.MassInput
 import Utils.Lens
 
 import Jobs.Queue
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index 92fbccf72..a9dbe1ede 100644
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@@ -1,5 +1,6 @@
 module Handler.Utils.Form
   ( module Handler.Utils.Form
+  , module Handler.Utils.Form.MassInput
   , module Utils.Form
   , MonadWriter(..)
   ) where
@@ -35,6 +36,7 @@ import qualified Data.Map as Map
 import Control.Monad.Trans.Writer (execWriterT, WriterT)
 import Control.Monad.Trans.Except (throwE, runExceptT)
 import Control.Monad.Writer.Class
+import Control.Monad.Error.Class (MonadError(..))
 
 import Data.Scientific (Scientific)
 import Text.Read (readMaybe)
@@ -49,6 +51,13 @@ import Data.Proxy
 
 import qualified Text.Email.Validate as Email
 
+import Yesod.Core.Types (FileInfo(..))
+
+import System.FilePath (isExtensionOf)
+import Data.Text.Lens (unpacked)
+
+import Handler.Utils.Form.MassInput
+
 ----------------------------
 -- Buttons (new version ) --
 ----------------------------
@@ -341,14 +350,88 @@ studyFeaturesPrimaryFieldFor isOptional oldFeatures mbuid = selectField $ do
           }
 
 
-uploadModeField :: Field Handler UploadMode
-uploadModeField = selectField optionsFinite
+uploadModeForm :: Maybe UploadMode -> AForm Handler UploadMode
+uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUploadMode <$> prev)
+  where
+    actions :: Map UploadModeDescr (AForm Handler UploadMode)
+    actions = Map.fromList
+      [ ( UploadModeNone, pure NoUpload)
+      , ( UploadModeAny
+        , UploadAny
+          <$> apreq checkBoxField (fslI MsgUploadModeUnpackZips & setTooltip MsgUploadModeUnpackZipsTip) (prev ^? _Just . _unpackZips)
+          <*> apreq extensionRestrictionField (fslI MsgUploadModeExtensionRestriction & setTooltip MsgUploadModeExtensionRestrictionTip) ((prev ^? _Just . _extensionRestriction) <|> fmap Just defaultExtensionRestriction)
+        )
+      , ( UploadModeSpecific
+        , UploadSpecific <$> specificFileForm
+        )
+      ]
+  
+    extensionRestrictionField :: Field Handler (Maybe (NonNull (Set Extension)))
+    extensionRestrictionField = convertField (fromNullable . toSet) (maybe "" $ intercalate ", " . Set.toList . toNullable) textField
+      where
+        toSet = Set.fromList . filter (not . Text.null) . map (stripDot . Text.strip) . Text.splitOn ","
+        stripDot ext
+          | Just nExt <- Text.stripPrefix "." ext = nExt
+          | otherwise = ext
+    
+    specificFileForm :: AForm Handler (NonNull (Set UploadSpecificFile))
+    specificFileForm = wFormToAForm $ do
+      Just currentRoute <- getCurrentRoute
+      let miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
+          miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag
+      miIdent <- ("specific-files--" <>) <$> newIdent
+      postProcess =<< massInputW MassInput{..} (fslI MsgUploadSpecificFiles & setTooltip MsgMassInputTip) True (preProcess <$> prev ^? _Just . _specificFiles)
+      where
+        preProcess :: NonNull (Set UploadSpecificFile) -> Map ListPosition (UploadSpecificFile, UploadSpecificFile)
+        preProcess = Map.fromList . zip [0..] . map (\x -> (x, x)) . Set.toList . toNullable
+        
+        postProcess :: FormResult (Map ListPosition (UploadSpecificFile, UploadSpecificFile)) -> WForm Handler (FormResult (NonNull (Set UploadSpecificFile)))
+        postProcess mapResult = do
+          MsgRenderer mr <- getMsgRenderer
+          return $ do
+            mapResult' <- Set.fromList . map snd . Map.elems <$> mapResult
+            case fromNullable mapResult' of
+              Nothing -> throwError [mr MsgNoUploadSpecificFilesConfigured]
+              Just lResult -> do
+                let names = Set.map specificFileName mapResult'
+                    labels = Set.map specificFileLabel mapResult'
+                if
+                  | Set.size names /= Set.size mapResult'
+                    -> throwError [mr MsgUploadSpecificFilesDuplicateNames]
+                  | Set.size labels /= Set.size mapResult'
+                    -> throwError [mr MsgUploadSpecificFilesDuplicateLabels]
+                  | otherwise
+                    -> return lResult
+
+        sFileForm :: (Text -> Text) -> Maybe UploadSpecificFile -> Form UploadSpecificFile
+        sFileForm nudge mPrevUF csrf = do
+          (labelRes, labelView) <- mpreq textField ("" & addName (nudge "label")) $ specificFileLabel <$> mPrevUF
+          (nameRes, nameView) <- mpreq textField ("" & addName (nudge "name")) $ specificFileName <$> mPrevUF
+          (reqRes, reqView) <- mpreq checkBoxField ("" & addName (nudge "required")) $ specificFileRequired <$> mPrevUF
+
+          return ( UploadSpecificFile <$> labelRes <*> nameRes <*> reqRes
+                 , $(widgetFile "widgets/massinput/uploadSpecificFiles/form")
+                 )
+
+        miAdd _ _ nudge submitView = Just $ \csrf -> do
+          (formRes, formWidget) <- sFileForm nudge Nothing csrf
+          let formWidget' = $(widgetFile "widgets/massinput/uploadSpecificFiles/add")
+              addRes' = formRes <&> \fileRes oldRess ->
+                let iStart = maybe 0 (succ . fst) $ Map.lookupMax oldRess
+                 in pure $ Map.singleton iStart fileRes
+          return (addRes', formWidget')
+        miCell _ initFile initFile' nudge csrf =
+          sFileForm nudge (Just $ fromMaybe initFile initFile') csrf
+        miDelete = miDeleteList
+        miAllowAdd _ _ _ = True
+        miAddEmpty _ _ _ = Set.empty
+        miLayout :: MassInputLayout ListLength UploadSpecificFile UploadSpecificFile
+        miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/uploadSpecificFiles/layout")
+                                               
 
 submissionModeForm :: Maybe SubmissionMode -> AForm Handler SubmissionMode
 submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ classifySubmissionMode <$> prev
   where
-    uploadModeForm = apreq uploadModeField (fslI MsgSheetUploadMode) (preview (_Just . _submissionModeUser . _Just) $ prev)
-
     actions :: Map SubmissionModeDescr (AForm Handler SubmissionMode)
     actions = Map.fromList
       [ ( SubmissionModeNone
@@ -358,10 +441,10 @@ submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ c
         , pure $ SubmissionMode True  Nothing
         )
       , ( SubmissionModeUser
-        , SubmissionMode False . Just <$> uploadModeForm
+        , SubmissionMode False . Just <$> uploadModeForm (prev ^? _Just . _submissionModeUser . _Just)
         )
       , ( SubmissionModeBoth
-        , SubmissionMode True  . Just <$> uploadModeForm
+        , SubmissionMode True  . Just <$> uploadModeForm (prev ^? _Just . _submissionModeUser . _Just)
         )
       ]
 
@@ -374,17 +457,41 @@ pseudonymWordField = checkMMap doCheck CI.original $ textField & addDatalist (re
       | otherwise
       = return . Left $ MsgUnknownPseudonymWord (CI.original w)
 
-zipFileField :: Bool -- ^ Unpack zips?
-             -> Field Handler (Source Handler File)
-zipFileField doUnpack = Field{..}
+specificFileField :: UploadSpecificFile -> Field Handler (Source Handler File)
+specificFileField UploadSpecificFile{..} = Field{..}
   where
     fieldEnctype = Multipart
     fieldParse _ files
-      | [f] <- files = return . Right . Just $ bool (yieldM . acceptFile) sourceFiles doUnpack f
+      | [f] <- files
+      = return . Right . Just $ yieldM (acceptFile f) .| modifyFileTitle (const $ unpack specificFileName)
+      | null files   = return $ Right Nothing
+      | otherwise    = return . Left $ SomeMessage MsgOnlyUploadOneFile
+    fieldView fieldId fieldName attrs _ req = $(widgetFile "widgets/specificFileField")
+
+    extensions = fileNameExtensions specificFileName
+    acceptRestricted = not $ null extensions
+    accept = Text.intercalate "," . map ("." <>) $ extensions
+
+
+zipFileField :: Bool -- ^ Unpack zips?
+             -> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions
+             -> Field Handler (Source Handler File)
+zipFileField doUnpack permittedExtensions = Field{..}
+  where
+    fieldEnctype = Multipart
+    fieldParse _ files
+      | [f@FileInfo{..}] <- files
+      , maybe True (anyOf (re _nullable . folded . unpacked) (`isExtensionOf` unpack fileName)) permittedExtensions || doUnpack
+      = return . Right . Just $ bool (yieldM . acceptFile) sourceFiles doUnpack f
       | null files   = return $ Right Nothing
       | otherwise    = return . Left $ SomeMessage MsgOnlyUploadOneFile
     fieldView fieldId fieldName attrs _ req = $(widgetFile "widgets/zipFileField")
 
+    zipExtensions = mimeExtensions "application/zip"
+
+    acceptRestricted = isJust permittedExtensions
+    accept = Text.intercalate "," . map ("." <>) $ bool [] (Set.toList zipExtensions) doUnpack ++ toListOf (_Just . re _nullable . folded) permittedExtensions
+
 multiFileField :: Handler (Set FileId) -> Field Handler (Source Handler (Either FileId File))
 multiFileField permittedFiles' = Field{..}
   where
@@ -590,23 +697,6 @@ jsonField hide = Field{..}
     |]
     fieldEnctype = UrlEncoded
 
-secretJsonField :: ( ToJSON a, FromJSON a
-                   , MonadHandler m
-                   , HandlerSite m ~ UniWorX
-                   )
-                => Field m a
-secretJsonField = Field{..}
-  where
-    fieldParse [v] [] = bimap (\_ -> SomeMessage MsgSecretJSONFieldDecryptFailure) Just <$> runExceptT (encodedSecretBoxOpen v)
-    fieldParse [] [] = return $ Right Nothing
-    fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
-    fieldView theId name attrs val _isReq = do
-      val' <- traverse (encodedSecretBox SecretBoxShort) val
-      [whamlet|
-        
-      |]
-    fieldEnctype = UrlEncoded
-
 boolField :: ( MonadHandler m
              , HandlerSite m ~ UniWorX
              )
diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs
index cd5e4f5ac..e9121be5f 100644
--- a/src/Handler/Utils/Form/MassInput.hs
+++ b/src/Handler/Utils/Form/MassInput.hs
@@ -17,7 +17,6 @@ module Handler.Utils.Form.MassInput
 import Import
 import Utils.Form
 import Utils.Lens
-import Handler.Utils.Form (secretJsonField)
 import Handler.Utils.Form.MassInput.Liveliness
 import Handler.Utils.Form.MassInput.TH
 
diff --git a/src/Handler/Utils/Form/Occurences.hs b/src/Handler/Utils/Form/Occurences.hs
index f39ec3323..da0e7733f 100644
--- a/src/Handler/Utils/Form/Occurences.hs
+++ b/src/Handler/Utils/Form/Occurences.hs
@@ -4,7 +4,6 @@ module Handler.Utils.Form.Occurences
 
 import Import
 import Handler.Utils.Form
-import Handler.Utils.Form.MassInput
 import Handler.Utils.DateTime
 
 import qualified Data.Set as Set
diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs
index ef297bff4..09c59f6b3 100644
--- a/src/Handler/Utils/Submission.hs
+++ b/src/Handler/Utils/Submission.hs
@@ -318,8 +318,10 @@ extractRatingsMsg = do
   let ignoredFiles :: Set (Either CryptoFileNameSubmission FilePath)
       ignoredFiles = Right `Set.map` ignored'
   unless (null ignoredFiles) $ do
-    mr <- (toHtml . ) <$> getMessageRender
-    addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
+    let ignoredModal = msgModal
+          [whamlet|_{MsgSubmissionFilesIgnored (Set.size ignoredFiles)}|]
+          (Right $(widgetFile "messages/submissionFilesIgnored"))
+    addMessageWidget Warning ignoredModal
 
 -- Nicht innerhalb von runDB aufrufen, damit das DB Rollback passieren kann!
 msgSubmissionErrors :: (MonadHandler m, MonadCatch m, HandlerSite m ~ UniWorX) => m a -> m (Maybe a)
@@ -362,10 +364,28 @@ sinkSubmission userId mExists isUpdate = do
       return sId
     Right sId -> return sId
 
-  sId <$ sinkSubmission' sId
+  Sheet{..} <- lift $ case mExists of
+    Left sheetId -> getJust sheetId
+    Right subId  -> getJust . submissionSheet =<< getJust subId
+
+  sId <$ (guardFileTitles sheetSubmissionMode .| sinkSubmission' sId)
   where
     tellSt = modify . mappend
 
+    guardFileTitles :: MonadThrow m => SubmissionMode -> Conduit SubmissionContent m SubmissionContent
+    guardFileTitles SubmissionMode{..}
+      | Just UploadAny{..} <- submissionModeUser
+      , not isUpdate
+      , Just (map unpack . Set.toList . toNullable -> exts) <- extensionRestriction
+      = Conduit.mapM $ \x -> if
+          | Left File{..} <- x
+          , none (`isExtensionOf` fileTitle) exts
+          , isn't _Nothing fileContent -- File record is not a directory, we don't care about those
+            -> throwM $ InvalidFileTitleExtension fileTitle
+          | otherwise
+            -> return x
+      | otherwise = Conduit.map id
+
     sinkSubmission' :: SubmissionId
                     -> Sink SubmissionContent (YesodJobDB UniWorX) ()
     sinkSubmission' submissionId = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs
index 7006bd5e5..975ae3925 100644
--- a/src/Import/NoFoundation.hs
+++ b/src/Import/NoFoundation.hs
@@ -99,6 +99,8 @@ import Data.CaseInsensitive as Import (CI, FoldCase(..), foldedCase)
 
 import Data.Ratio as Import ((%))
 
+import Network.Mime as Import
+
 
 import Control.Monad.Trans.RWS (RWST)
 
diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs
index f55638835..f220e4353 100644
--- a/src/Model/Migration.hs
+++ b/src/Model/Migration.hs
@@ -279,8 +279,8 @@ customMigrations = Map.fromListWith (>>)
                 ( Legacy.NoSubmissions       , _                   ) -> SubmissionMode False Nothing
                 ( Legacy.CorrectorSubmissions, _                   ) -> SubmissionMode True Nothing
                 ( Legacy.UserSubmissions     , Legacy.NoUpload     ) -> SubmissionMode False (Just NoUpload)
-                ( Legacy.UserSubmissions     , Legacy.Upload True  ) -> SubmissionMode False (Just $ Upload True)
-                ( Legacy.UserSubmissions     , Legacy.Upload False ) -> SubmissionMode False (Just $ Upload False)
+                ( Legacy.UserSubmissions     , Legacy.Upload True  ) -> SubmissionMode False (Just $ UploadAny True defaultExtensionRestriction)
+                ( Legacy.UserSubmissions     , Legacy.Upload False ) -> SubmissionMode False (Just $ UploadAny False defaultExtensionRestriction)
           [executeQQ| UPDATE "sheet" SET "submission_mode" = #{submissionMode'} WHERE "id" = #{shid}; |]
     )
   , ( AppliedMigrationKey [migrationVersion|11.0.0|] [version|12.0.0|]
diff --git a/src/Model/Submission.hs b/src/Model/Submission.hs
index 0f931911b..24ef1bad6 100644
--- a/src/Model/Submission.hs
+++ b/src/Model/Submission.hs
@@ -7,6 +7,7 @@ data SubmissionSinkException = DuplicateFileTitle FilePath
                              | DuplicateRating
                              | RatingWithoutUpdate
                              | ForeignRating CryptoFileNameSubmission
+                             | InvalidFileTitleExtension FilePath
   deriving (Typeable, Show)
 
 instance Exception SubmissionSinkException
diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs
index a754d0d0b..6ec4ae4f0 100644
--- a/src/Model/Types/Sheet.hs
+++ b/src/Model/Types/Sheet.hs
@@ -16,7 +16,6 @@ import Generics.Deriving.Monoid (memptydefault, mappenddefault)
 import Data.Typeable (Typeable)
 import Data.Universe
 import Data.Universe.Helpers
-import Data.Universe.TH
 import Data.Universe.Instances.Reverse ()
 
 import Data.NonNull.Instances ()
@@ -34,6 +33,8 @@ import Database.Persist.TH hiding (derivePersistFieldJSON)
 import Model.Types.JSON
 import Yesod.Core.Dispatch (PathPiece(..))
 
+import Network.Mime
+
 
 
 ----
@@ -210,9 +211,11 @@ partitionFileType fs t = Map.findWithDefault Set.empty t . Map.fromListWith Set.
 data SubmissionFileType = SubmissionOriginal | SubmissionCorrected
   deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
 
-instance Universe SubmissionFileType where universe = universeDef
+instance Universe SubmissionFileType
 instance Finite SubmissionFileType
 
+nullaryPathPiece ''SubmissionFileType $ camelToPathPiece' 1
+
 submissionFileTypeIsUpdate :: SubmissionFileType -> Bool
 submissionFileTypeIsUpdate SubmissionOriginal  = False
 submissionFileTypeIsUpdate SubmissionCorrected = True
@@ -221,41 +224,52 @@ isUpdateSubmissionFileType :: Bool -> SubmissionFileType
 isUpdateSubmissionFileType False = SubmissionOriginal
 isUpdateSubmissionFileType True  = SubmissionCorrected
 
-instance PathPiece SubmissionFileType where
-  toPathPiece SubmissionOriginal  = "original"
-  toPathPiece SubmissionCorrected = "corrected"
-  fromPathPiece = finiteFromPathPiece
 
--- instance DisplayAble SubmissionFileType where
---   display SubmissionOriginal  = "Abgabe"
---   display SubmissionCorrected = "Korrektur"
+data UploadSpecificFile = UploadSpecificFile
+  { specificFileLabel :: Text
+  , specificFileName :: FileName
+  , specificFileRequired :: Bool
+  } deriving (Show, Read, Eq, Ord, Generic)
 
-{-
-data DA = forall a . (DisplayAble a) => DA a
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 2
+  } ''UploadSpecificFile
+derivePersistFieldJSON ''UploadSpecificFile
 
-instance DisplayAble DA where
-  display (DA x) = display x
--}
-
-
-data UploadMode = NoUpload | Upload { unpackZips :: Bool }
+data UploadMode = NoUpload
+                | UploadAny
+                  { unpackZips :: Bool
+                  , extensionRestriction :: Maybe (NonNull (Set Extension))
+                  }
+                | UploadSpecific
+                  { specificFiles :: NonNull (Set UploadSpecificFile)
+                  }
   deriving (Show, Read, Eq, Ord, Generic)
 
-deriveFinite ''UploadMode
+defaultExtensionRestriction :: Maybe (NonNull (Set Extension))
+defaultExtensionRestriction = fromNullable $ Set.fromList ["txt", "pdf"]
 
 deriveJSON defaultOptions
   { constructorTagModifier = camelToPathPiece
   , fieldLabelModifier = camelToPathPiece
   , sumEncoding = TaggedObject "mode" "settings"
+  , omitNothingFields = True
   }''UploadMode
 derivePersistFieldJSON ''UploadMode
 
-instance PathPiece UploadMode where
-  toPathPiece = \case
-    NoUpload     -> "no-upload"
-    Upload True  -> "unpack"
-    Upload False -> "no-unpack"
-  fromPathPiece = finiteFromPathPiece
+data UploadModeDescr = UploadModeNone
+                     | UploadModeAny
+                     | UploadModeSpecific
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+instance Universe UploadModeDescr
+instance Finite UploadModeDescr
+
+nullaryPathPiece ''UploadModeDescr $ camelToPathPiece' 2
+
+classifyUploadMode :: UploadMode -> UploadModeDescr
+classifyUploadMode NoUpload = UploadModeNone
+classifyUploadMode UploadAny{} = UploadModeAny
+classifyUploadMode UploadSpecific{} = UploadModeSpecific
 
 data SubmissionMode = SubmissionMode
   { submissionModeCorrector :: Bool
@@ -263,24 +277,11 @@ data SubmissionMode = SubmissionMode
   }
   deriving (Show, Read, Eq, Ord, Generic)
 
-deriveFinite ''SubmissionMode
-
 deriveJSON defaultOptions
   { fieldLabelModifier = camelToPathPiece' 2
   } ''SubmissionMode
 derivePersistFieldJSON ''SubmissionMode
 
-finitePathPiece ''SubmissionMode
-  [ "no-submissions"
-  , "no-upload"
-  , "no-unpack"
-  , "unpack"
-  , "correctors"
-  , "correctors+no-upload"
-  , "correctors+no-unpack"
-  , "correctors+unpack"
-  ]
-
 data SubmissionModeDescr = SubmissionModeNone
                          | SubmissionModeCorrector
                          | SubmissionModeUser
@@ -336,4 +337,4 @@ instance Monoid Load where
   isByTutorial :: Load -> Bool
   isByTutorial (ByTutorial {}) = True
   isByTutorial _               = False
--}
\ No newline at end of file
+-}
diff --git a/src/Network/Mime/TH.hs b/src/Network/Mime/TH.hs
index 0fd1c2beb..486eda779 100644
--- a/src/Network/Mime/TH.hs
+++ b/src/Network/Mime/TH.hs
@@ -1,11 +1,12 @@
 module Network.Mime.TH
-  ( mimeMapFile
+  ( mimeMapFile, mimeSetFile
   ) where
 
 import ClassyPrelude.Yesod hiding (lift)
 import Language.Haskell.TH hiding (Extension)
 import Language.Haskell.TH.Syntax (qAddDependentFile, Lift(..))
 
+import qualified Data.Set as Set
 import qualified Data.Map as Map
 
 import Data.Text (Text)
@@ -18,7 +19,7 @@ import Network.Mime
 import Instances.TH.Lift ()
 
 
-mimeMapFile :: FilePath -> ExpQ
+mimeMapFile, mimeSetFile :: FilePath -> ExpQ
 mimeMapFile file = do
   qAddDependentFile file
   
@@ -36,6 +37,15 @@ mimeMapFile file = do
 
 
   lift mimeMap
+mimeSetFile file = do
+  qAddDependentFile file
+  
+  ls <- runIO $ filter (not . isComment) . Text.lines <$> Text.readFile file
+
+  let mimeSet :: Set MimeType
+      mimeSet = Set.fromList $ map (encodeUtf8 . Text.strip) ls
+
+  lift mimeSet
 
 isComment :: Text -> Bool
 isComment line = or
diff --git a/src/Settings.hs b/src/Settings.hs
index 739ac5554..a60b4597b 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -73,6 +73,9 @@ import Handler.Utils.Submission.TH
 import Network.Mime
 import Network.Mime.TH
 
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
 
 -- | Runtime settings to configure this application. These settings can be
 -- loaded from various sources: defaults, environment variables, config files,
@@ -431,8 +434,17 @@ widgetFileSettings = def
 submissionBlacklist :: [Pattern]
 submissionBlacklist = $(patternFile compDefault "config/submission-blacklist")
 
+mimeMap :: MimeMap
+mimeMap = $(mimeMapFile "config/mimetypes")
+
 mimeLookup :: FileName -> MimeType
-mimeLookup = mimeByExt $(mimeMapFile "config/mimetypes") defaultMimeType
+mimeLookup = mimeByExt mimeMap defaultMimeType
+
+mimeExtensions :: MimeType -> Set Extension
+mimeExtensions needle = Set.fromList [ ext | (ext, typ) <- Map.toList mimeMap, typ == needle ]
+
+archiveTypes :: Set MimeType
+archiveTypes = $(mimeSetFile "config/archive-types")
 
 -- The rest of this file contains settings which rarely need changing by a
 -- user.
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index ad62f224f..c11496380 100644
--- a/src/Utils/Form.hs
+++ b/src/Utils/Form.hs
@@ -24,6 +24,7 @@ import Control.Monad.Trans.Maybe (MaybeT(..))
 import Control.Monad.Reader.Class (MonadReader(..))
 import Control.Monad.Writer.Class (MonadWriter(..))
 import Control.Monad.Trans.RWS (mapRWST)
+import Control.Monad.Trans.Except (ExceptT, runExceptT)
 
 import Data.List ((!!))
 
@@ -445,6 +446,29 @@ optionsFinite = do
 rationalField :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage) => Field m Rational
 rationalField = convertField toRational fromRational doubleField
 
+data SecretJSONFieldException = SecretJSONFieldDecryptFailure
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+instance Exception SecretJSONFieldException
+
+secretJsonField :: ( ToJSON a, FromJSON a
+                   , MonadHandler m
+                   , MonadSecretBox (ExceptT EncodedSecretBoxException m)
+                   , MonadSecretBox (WidgetT (HandlerSite m) IO)
+                   , RenderMessage (HandlerSite m) FormMessage
+                   , RenderMessage (HandlerSite m) SecretJSONFieldException
+                   )
+                => Field m a
+secretJsonField = Field{..}
+  where
+    fieldParse [v] [] = bimap (\_ -> SomeMessage SecretJSONFieldDecryptFailure) Just <$> runExceptT (encodedSecretBoxOpen v)
+    fieldParse [] [] = return $ Right Nothing
+    fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
+    fieldView theId name attrs val _isReq = do
+      val' <- traverse (encodedSecretBox SecretBoxShort) val
+      [whamlet|
+        
+      |]
+    fieldEnctype = UrlEncoded
 
 -----------
 -- Forms --
diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs
index d52b852c8..51aa57fd0 100644
--- a/src/Utils/Lens.hs
+++ b/src/Utils/Lens.hs
@@ -103,6 +103,8 @@ makePrisms ''HandlerContents
 
 makePrisms ''ErrorResponse
 
+makeLenses_ ''UploadMode
+
 makeLenses_ ''SubmissionMode
 
 makePrisms ''E.Value
diff --git a/stack.yaml b/stack.yaml
index 7fadc6e4e..02b25ee57 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -51,4 +51,6 @@ extra-deps:
 
   - systemd-1.2.0
 
+  - filepath-1.4.2
+
 resolver: lts-10.5
diff --git a/templates/messages/submissionFilesIgnored.hamlet b/templates/messages/submissionFilesIgnored.hamlet
index ebb61695e..628125d9f 100644
--- a/templates/messages/submissionFilesIgnored.hamlet
+++ b/templates/messages/submissionFilesIgnored.hamlet
@@ -1,4 +1,4 @@
-_{MsgSubmissionFilesIgnored}
+
_{MsgSubmissionFilesIgnored (Set.size ignoredFiles)}
 
    
   $forall ident <- ignoredFiles
     $case ident
diff --git a/templates/widgets/massinput/uploadSpecificFiles/add.hamlet b/templates/widgets/massinput/uploadSpecificFiles/add.hamlet
new file mode 100644
index 000000000..6ef4903fb
--- /dev/null
+++ b/templates/widgets/massinput/uploadSpecificFiles/add.hamlet
@@ -0,0 +1,4 @@
+$newline never
+^{formWidget}
+
+  ^{fvInput submitView}
diff --git a/templates/widgets/massinput/uploadSpecificFiles/form.hamlet b/templates/widgets/massinput/uploadSpecificFiles/form.hamlet
new file mode 100644
index 000000000..46e856c46
--- /dev/null
+++ b/templates/widgets/massinput/uploadSpecificFiles/form.hamlet
@@ -0,0 +1,4 @@
+$newline never
+#{csrf}^{fvInput labelView}
+^{fvInput nameView}
+^{fvInput reqView}
diff --git a/templates/widgets/massinput/uploadSpecificFiles/layout.hamlet b/templates/widgets/massinput/uploadSpecificFiles/layout.hamlet
new file mode 100644
index 000000000..2179c82b1
--- /dev/null
+++ b/templates/widgets/massinput/uploadSpecificFiles/layout.hamlet
@@ -0,0 +1,16 @@
+$newline never
+
+  
+    
+    $forall coord <- review liveCoords lLength
+      
+        ^{cellWdgts ! coord}
+        
+    
+      ^{addWdgts ! (0, 0)}
diff --git a/templates/widgets/specificFileField.hamlet b/templates/widgets/specificFileField.hamlet
new file mode 100644
index 000000000..2f77bae30
--- /dev/null
+++ b/templates/widgets/specificFileField.hamlet
@@ -0,0 +1,8 @@
+$newline never
+
+$if acceptRestricted
+  
    
+  _{MsgUploadModeExtensionRestriction}: 
+  
      
+    $forall ext <- extensions
+      
    • #{ext}
diff --git a/templates/widgets/zipFileField.hamlet b/templates/widgets/zipFileField.hamlet
index 4c432c524..1e39effa6 100644
--- a/templates/widgets/zipFileField.hamlet
+++ b/templates/widgets/zipFileField.hamlet
@@ -1,2 +1,8 @@
 $newline never
-
+
+$maybe exts <- fmap toNullable permittedExtensions
+  
      
+  _{MsgUploadModeExtensionRestriction}: 
+  
        
+    $forall ext <- zipExtensions <> exts
+      
      • #{ext}
diff --git a/test/Database.hs b/test/Database.hs
index 5f9140cb0..6332584b4 100755
--- a/test/Database.hs
+++ b/test/Database.hs
@@ -393,11 +393,11 @@ fillDb = do
   void . insert $ DegreeCourse ffp sdMst sdInf
   void . insert $ Lecturer jost   ffp CourseLecturer
   void . insert $ Lecturer gkleen ffp CourseAssistant
-  adhoc <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ Upload True) False
+  adhoc <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ UploadAny True Nothing) False
   insert_ $ SheetEdit gkleen now adhoc
-  feste <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ Upload True) False
+  feste <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ UploadAny True Nothing) False
   insert_ $ SheetEdit gkleen now feste
-  keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ Upload True) False
+  keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ UploadAny True Nothing) False
   insert_ $ SheetEdit gkleen now keine
   void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf)
     [(fhamann   , Nothing)
@@ -484,7 +484,7 @@ fillDb = do
     ]
   sh1 <- insert Sheet
     { sheetCourse = pmo
-    , sheetName = "Blatt 1"
+    , sheetName = "Papierabgabe"
     , sheetDescription = Nothing
     , sheetType = Normal $ Points 6
     , sheetGrouping = Arbitrary 3
@@ -516,6 +516,60 @@ fillDb = do
   void . insert $ SubmissionUser maxMuster sub1
   sub1fid1 <- insertFile "AbgabeH10-1.hs"
   void . insert $ SubmissionFile sub1 sub1fid1 False False
+  sh2 <- insert Sheet
+    { sheetCourse = pmo
+    , sheetName = "Spezifische Abgabe"
+    , sheetDescription = Nothing
+    , sheetType = Normal $ Points 6
+    , sheetGrouping = Arbitrary 3
+    , sheetMarkingText = Nothing
+    , sheetVisibleFrom = Just now
+    , sheetActiveFrom = now
+    , sheetActiveTo = (14 * nominalDay) `addUTCTime` now
+    , sheetSubmissionMode = SubmissionMode False $ Just UploadSpecific
+      { specificFiles = impureNonNull $ Set.fromList
+        [ UploadSpecificFile "Aufgabe 1" "exercise_2.1.hs" False
+        , UploadSpecificFile "Aufgabe 2" "exercise_2.2.hs" False
+        , UploadSpecificFile "Erklärung der Eigenständigkeit" "erklärung.txt" True
+        ]
+      }
+    , sheetHintFrom = Nothing
+    , sheetSolutionFrom = Nothing
+    , sheetAutoDistribute = True
+    }
+  void . insert $ SheetEdit jost now sh2
+  sh3 <- insert Sheet
+    { sheetCourse = pmo
+    , sheetName = "Dateiendung-eingeschränkte Abgabe"
+    , sheetDescription = Nothing
+    , sheetType = Normal $ Points 6
+    , sheetGrouping = Arbitrary 3
+    , sheetMarkingText = Nothing
+    , sheetVisibleFrom = Just now
+    , sheetActiveFrom = now
+    , sheetActiveTo = (14 * nominalDay) `addUTCTime` now
+    , sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction
+    , sheetHintFrom = Nothing
+    , sheetSolutionFrom = Nothing
+    , sheetAutoDistribute = True
+    }
+  void . insert $ SheetEdit jost now sh3
+  sh4 <- insert Sheet
+    { sheetCourse = pmo
+    , sheetName = "Uneingeschränkte Abgabe, einzelne Datei"
+    , sheetDescription = Nothing
+    , sheetType = Normal $ Points 6
+    , sheetGrouping = Arbitrary 3
+    , sheetMarkingText = Nothing
+    , sheetVisibleFrom = Just now
+    , sheetActiveFrom = now
+    , sheetActiveTo = (14 * nominalDay) `addUTCTime` now
+    , sheetSubmissionMode = SubmissionMode False . Just $ UploadAny False Nothing
+    , sheetHintFrom = Nothing
+    , sheetSolutionFrom = Nothing
+    , sheetAutoDistribute = True
+    }
+  void . insert $ SheetEdit jost now sh4
   tut1 <- insert Tutorial
     { tutorialName = "Di08"
     , tutorialCourse = pmo

From 813d44697591daeae76f1579d9e3f1ef0b4118f8 Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Sat, 18 May 2019 23:14:21 +0200
Subject: [PATCH 11/13] Divide sheetForm into sections

---
 messages/uniworx/de.msg |  5 +++++
 src/Handler/Sheet.hs    | 40 +++++++++++++++++++++-------------------
 src/Utils/Form.hs       |  3 +++
 3 files changed, 29 insertions(+), 19 deletions(-)

diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index 9ea58fd65..70f005dfc 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -169,6 +169,7 @@ SheetHintFrom: Hinweis ab
 SheetSolution: Lösung
 SheetSolutionFrom: Lösung ab
 SheetMarking: Hinweise für Korrektoren
+SheetMarkingFiles: Korrektur
 SheetType: Wertung
 SheetInvisible: Dieses Übungsblatt ist für Teilnehmer momentan unsichtbar!
 SheetInvisibleUntil date@Text: Dieses Übungsblatt ist für Teilnehmer momentan unsichtbar bis #{date}!
@@ -186,6 +187,10 @@ SheetMarkingTip: Hinweise zur Korrektur, sichtbar nur für Korrektoren
 SheetPseudonym: Persönliches Abgabe-Pseudonym
 SheetGeneratePseudonym: Generieren
 
+SheetFormType: Wertung & Abgabe
+SheetFormTimes: Zeiten
+SheetFormFiles: Dateien
+
 SheetErrVisibility: "Beginn Abgabezeitraum" muss nach "Sichbar für Teilnehmer ab" liegen
 SheetErrDeadlineEarly: "Ende Abgabezeitraum" muss nach "Beginn Abzeitraum" liegen
 SheetErrHintEarly: Hinweise dürfen erst nach Beginn des Abgabezeitraums herausgegeben werden
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index 0b0b62e40..f315c7709 100644
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@@ -68,19 +68,19 @@ import Text.Hamlet (ihamlet)
 
 data SheetForm = SheetForm
       { sfName         :: SheetName
-      , sfDescription  :: Maybe Html
-      , sfType         :: SheetType
-      , sfGrouping     :: SheetGroup
       , sfVisibleFrom  :: Maybe UTCTime
       , sfActiveFrom   :: UTCTime
       , sfActiveTo     :: UTCTime
-      , sfSubmissionMode :: SubmissionMode
-      , sfSheetF       :: Maybe (Source Handler (Either FileId File))
       , sfHintFrom     :: Maybe UTCTime
-      , sfHintF        :: Maybe (Source Handler (Either FileId File))
       , sfSolutionFrom :: Maybe UTCTime
+      , sfSheetF       :: Maybe (Source Handler (Either FileId File))
+      , sfHintF        :: Maybe (Source Handler (Either FileId File))
       , sfSolutionF    :: Maybe (Source Handler (Either FileId File))
       , sfMarkingF     :: Maybe (Source Handler (Either FileId File))
+      , sfType         :: SheetType
+      , sfGrouping     :: SheetGroup
+      , sfSubmissionMode :: SubmissionMode
+      , sfDescription  :: Maybe Html
       , sfMarkingText  :: Maybe Html
       -- Keine SheetId im Formular!
       }
@@ -102,12 +102,7 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
     ctime <- ceilingQuarterHour <$> liftIO getCurrentTime
     (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
       <$> areq ciField        (fslI MsgSheetName)         (sfName        <$> template)
-      <*> aopt htmlField      (fslpI MsgSheetDescription "Html")
-                                                          (sfDescription <$> template)
-      <*> sheetTypeAFormReq   (fslI MsgSheetType
-            & setTooltip (uniworxMessages [MsgSheetTypeInfoBonus,MsgSheetTypeInfoNotGraded]))
-                                                          (sfType        <$> template)
-      <*> sheetGroupAFormReq  (fslI MsgSheetGroup)        (sfGrouping    <$> template)
+      <* aformSection MsgSheetFormTimes
       <*> aopt utcTimeField   (fslI MsgSheetVisibleFrom
             & setTooltip MsgSheetVisibleFromTip)
                                                               ((sfVisibleFrom  <$> template) <|> pure (Just ctime))
@@ -115,17 +110,24 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
             & setTooltip MsgSheetActiveFromTip)
                                                               (sfActiveFrom   <$> template)
       <*> areq utcTimeField   (fslI MsgSheetActiveTo)         (sfActiveTo     <$> template)
-      <*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction))
-      <*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
       <*> aopt utcTimeField   (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren"
             & setTooltip MsgSheetHintFromTip)                 (sfHintFrom     <$> template)
-      <*> aopt (multiFileField $ oldFileIds SheetHint)     (fslI MsgSheetHint)      (sfHintF <$> template)
       <*> aopt utcTimeField   (fslpI MsgSheetSolutionFrom  "Datum, sonst nur für Korrektoren"
-            & setTooltip MsgSheetSolutionFromTip)
-                                                              (sfSolutionFrom <$> template)
+            & setTooltip MsgSheetSolutionFromTip)             (sfSolutionFrom <$> template)
+      <* aformSection MsgSheetFormFiles
+      <*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
+      <*> aopt (multiFileField $ oldFileIds SheetHint)     (fslI MsgSheetHint)      (sfHintF <$> template)
       <*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
-      <*> aopt (multiFileField $ oldFileIds SheetMarking)  (fslI MsgSheetMarking
-            & setTooltip MsgSheetMarkingTip)   (sfMarkingF <$> template)
+      <*> aopt (multiFileField $ oldFileIds SheetMarking)  (fslI MsgSheetMarkingFiles
+            & setTooltip MsgSheetMarkingTip)                  (sfMarkingF <$> template)
+      <* aformSection MsgSheetFormType
+      <*> sheetTypeAFormReq   (fslI MsgSheetType
+            & setTooltip (uniworxMessages [MsgSheetTypeInfoBonus,MsgSheetTypeInfoNotGraded]))
+                                                          (sfType        <$> template)
+      <*> sheetGroupAFormReq  (fslI MsgSheetGroup)        (sfGrouping    <$> template)
+      <*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction))
+      <*> aopt htmlField      (fslpI MsgSheetDescription "Html")
+                                                          (sfDescription <$> template)
       <*> aopt htmlField    (fslpI MsgSheetMarking "Html") (sfMarkingText <$> template)
     return $ case result of
       FormSuccess sheetResult
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index c11496380..c2797980d 100644
--- a/src/Utils/Form.hs
+++ b/src/Utils/Form.hs
@@ -546,6 +546,9 @@ idFormSectionNoinput = "form-section-noinput"
 aformSection :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site msg) => msg -> AForm m ()
 aformSection = formToAForm . fmap (second pure) . formSection
 
+wformSection :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> WForm m ()
+wformSection = void . aFormToWForm . aformSection
+
 formSection :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site msg) => msg -> MForm m (FormResult (), FieldView site) -- TODO: WIP, delete
 formSection formSectionTitle = do
     mr <- getMessageRender

From 22f5a655c5b1d655bad466c18e7332ced96a8103 Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Sat, 18 May 2019 23:51:50 +0200
Subject: [PATCH 12/13] Don't crash on unsafe migrations

---
 src/Model/Migration.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs
index f220e4353..9c8b1578b 100644
--- a/src/Model/Migration.hs
+++ b/src/Model/Migration.hs
@@ -79,7 +79,7 @@ migrateAll = do
 
 requiresMigration :: forall m. (MonadLogger m, MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m Bool
 requiresMigration = mapReaderT (exceptT return return) $ do
-  initial <- getMigration initialMigration
+  initial <- either id (map snd) <$> parseMigration initialMigration
   when (not $ null initial) $ do
     $logInfoS "Migration" $ intercalate "; " initial
     throwError True
@@ -89,7 +89,7 @@ requiresMigration = mapReaderT (exceptT return return) $ do
     $logInfoS "Migration" . intercalate ", " . map tshow $ Map.keys customs
     throwError True
     
-  automatic <- getMigration migrateAll'
+  automatic <- either id (map snd) <$> parseMigration migrateAll'
   when (not $ null automatic) $ do
     $logInfoS "Migration" $ intercalate "; " automatic
     throwError True

From 2b79b40bfba22990fb7800af56fd62e41a6fca8f Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Sun, 19 May 2019 00:40:54 +0200
Subject: [PATCH 13/13] Fix Haddock

---
 src/Handler/Corrections.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index bb547e7f7..78b5d187a 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -116,7 +116,7 @@ colSheet = sortable (Just "sheet") (i18nCell MsgSheet) $ \row ->
 colSheetType :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colSheetType = sortable (toNothing "sheetType") (i18nCell MsgSheetType) $
         i18nCell . sheetType <$> view (_dbrOutput . _2 . _entityVal)
-        -- $ \DBRow{ dbrOutput=(_, sheet, _, _, _, _) } -> i18nCell . sheetType $ entityVal sheet
+        -- \DBRow{ dbrOutput=(_, sheet, _, _, _, _) } -> i18nCell . sheetType $ entityVal sheet
 
 colCorrector :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case

    _{MsgUploadSpecificFileLabel}
+    _{MsgUploadSpecificFileName}
+    _{MsgUploadSpecificFileRequired}
+    
+  
    
+          ^{fvInput (delButtons ! coord)}
+