diff --git a/.vscode/tasks.json b/.vscode/tasks.json index 4c18542ba..36c10837e 100644 --- a/.vscode/tasks.json +++ b/.vscode/tasks.json @@ -69,6 +69,11 @@ "type": "npm", "script": "lint", "problemMatcher": [] + }, + { + "type": "npm", + "script": "release", + "problemMatcher": [] } ] } \ No newline at end of file diff --git a/CHANGELOG.md b/CHANGELOG.md index dadeb24b1..755e68cbb 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,46 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +### [5.2.3](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.2.2...v5.2.3) (2019-08-22) + + +### Bug Fixes + +* **csv exam import:** ignore unchanged noshow and voided ([a346524](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a346524)) + + + +### [5.2.2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.2.1...v5.2.2) (2019-08-22) + + + +### [5.2.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.2.0...v5.2.1) (2019-08-21) + + +### Bug Fixes + +* **csv upload exams:** allow ambiguous harmless study fields ([7d2937c](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/7d2937c)) + + + +## [5.2.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.1.0...v5.2.0) (2019-08-21) + + +### Bug Fixes + +* **csv import:** csv import preview help text adjusted ([b7321df](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/b7321df)) +* **csv import:** fix spelling and expand help text ([2c57a77](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/2c57a77)) +* **exam import:** inactive registered features may be selected ([3c4172c](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/3c4172c)) +* **routes:** change ex to sheet ([9d9ead9](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/9d9ead9)) +* **sheet list:** do not show icons for inaccessible items ([0bb9a0f](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/0bb9a0f)), closes [#421](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/421) + + +### Features + +* **csv import:** add explanation text ([6d0a4c1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/6d0a4c1)) + + + ## [5.1.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.0.2...v5.1.0) (2019-08-19) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 319ca6f36..7e29f48b9 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -181,7 +181,7 @@ CourseApplicationRated: Bewertung erfolgreich angepasst CourseApplicationRatingDeleted: Bewertung erfolgreich entfernt CourseApplicationDeleted csh@CourseShorthand: Bewerbung zu #{csh} erfolgreich zurückgezogen -CourseApplicationTitle displayName@Text csh@CourseShorthand: Bewerbung für #{csh}: #{displayName} +CourseApplicationTitle displayName@Text csh@CourseShorthand: Bewerbung für #{csh}: #{displayName} CourseApplicationText: Text-Bewerbung CourseApplicationFollowInstructions: Beachten Sie die Anweisungen zur Bewerbung! @@ -190,7 +190,7 @@ CourseRegistrationFollowInstructions: Beachten Sie die Anweisungen zur Anmeldung CourseApplicationFile: Bewerbung CourseApplicationFiles: Bewerbungsdatei(en) -CourseApplicationArchive: Zip-Archiv der Bewerbungsdatei(en) +CourseApplicationArchive: Zip-Archiv der Bewerbungsdatei(en) CourseRegistrationFile: Datei zur Anmeldung CourseRegistrationFiles: Datei(en) zur Anmeldung CourseRegistrationArchive: Zip-Archiv der Datei(en) zur Anmeldung @@ -1377,11 +1377,12 @@ BtnCsvImport: CSV-Datei importieren BtnCsvImportConfirm: CSV-Import abschließen CsvImportNotConfigured: CSV-Import nicht vorgesehen -CsvImportConfirmationHeading: CSV-Import abschließen -CsvImportConfirmationTip: Durch den CSV-Import würden die unten aufgeführten Änderungen vorgenommen. Bitte überprüfen Sie diese zunächst sorgfältig. +CsvImportConfirmationHeading: CSV-Import Vorschau (noch keine Änderungen importiert) +CsvImportConfirmationTip: Es wurden noch keine Änderungen übernommen! Durch den CSV-Import könnten die unten aufgeführten Änderungen vorgenommen werden. Wählen Sie jetzt die gewünschten Änderungen aus, bevor Sie den CSV-Import abschließen. CsvImportUnnecessary: Durch den CSV-Import würden keine Änderungen vorgenommen werden CsvImportSuccessful n@Int: CSV-Import erfolgreich, es #{pluralDE n "wurde eine Aktion" (mappend (mappend "wurden " (toMessage n)) " Aktionen")} durchgeführt CsvImportAborted: CSV-Import abgebrochen +CsvImportExplanationLabel: Hinweise zum CSV-Import Proportion c@Text of@Text prop@Rational: #{c}/#{of} (#{rationalToFixed2 (100 * prop)}%) diff --git a/package-lock.json b/package-lock.json index c0d813997..502adc269 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "5.1.0", + "version": "5.2.3", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 6795c3884..47227e837 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "5.1.0", + "version": "5.2.3", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 1d62936ac..193b3f64c 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 5.1.0 +version: 5.2.3 dependencies: # Due to a bug in GHC 8.0.1, we block its usage diff --git a/routes b/routes index 670718f01..d1da938d1 100644 --- a/routes +++ b/routes @@ -107,11 +107,11 @@ /notes CNotesR GET POST !corrector -- THIS route is used to check for overall course corrector access! /subs CCorrectionsR GET POST /subs/assigned CAssignR GET POST - /ex SheetListR GET !course-registered !materials !corrector - /ex/new SheetNewR GET POST - /ex/current SheetCurrentR GET !course-registered !materials !corrector - /ex/unassigned SheetOldUnassignedR GET - /ex/#SheetName SheetR: + /sheet SheetListR GET !course-registered !materials !corrector + /sheet/new SheetNewR GET POST + /sheet/current SheetCurrentR GET !course-registered !materials !corrector + /sheet/unassigned SheetOldUnassignedR GET + /sheet/#SheetName SheetR: /show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor /show/download SArchiveR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor /edit SEditR GET POST diff --git a/src/Foundation.hs b/src/Foundation.hs index 60c71de8f..26a321ed0 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -368,6 +368,11 @@ instance RenderMessage UniWorX a => RenderMessage UniWorX (ExamResult' a) where mr :: RenderMessage UniWorX msg => msg -> Text mr = renderMessage foundation ls +instance RenderMessage UniWorX (Either ExamPassed ExamGrade) where + renderMessage foundation ls = either mr mr + where + mr :: RenderMessage UniWorX msg => msg -> Text + mr = renderMessage foundation ls -- ToMessage instances for converting raw numbers to Text (no internationalization) @@ -758,7 +763,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of guard $ NTop (Just cTime) <= NTop allocationStaffAllocationTo return Authorized - + CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn @@ -871,7 +876,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do -- Checks `registerFrom` and `registerTo`, override as further routes become available now <- liftIO getCurrentTime - Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash + Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash guard $ NTop allocationRegisterFrom <= NTop (Just now) guard $ NTop (Just now) <= NTop allocationRegisterTo return Authorized @@ -889,7 +894,7 @@ tagAccessPredicate AuthStaffTime = APDB $ \_ route _ -> case route of AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do -- Checks `registerFrom` and `registerTo`, override as further routes become available now <- liftIO getCurrentTime - Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash + Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash guard $ NTop allocationStaffAllocationFrom <= NTop (Just now) guard $ NTop (Just now) <= NTop allocationStaffAllocationTo return Authorized diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 7f90ea2a5..6bd06b1b5 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -15,18 +15,18 @@ import Handler.Utils.Csv import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH - + import qualified Data.Csv as Csv - + import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.Set as Set - + import qualified Data.Text as Text import qualified Data.Text.Lens as Text - + import qualified Data.Conduit.List as C - + import qualified Data.CaseInsensitive as CI import Numeric.Lens (integral) @@ -108,7 +108,7 @@ data ExamUserTableCsv = ExamUserTableCsv , csvEUserExerciseNumPasses :: Maybe Int , csvEUserExercisePointsMax :: Maybe Points , csvEUserExerciseNumPassesMax :: Maybe Int - , csvEUserExamResult :: Maybe (Either ExamResultPassed ExamResultGrade) + , csvEUserExamResult :: Maybe ExamResultPassedGrade , csvEUserCourseNote :: Maybe Html } deriving (Generic) @@ -208,7 +208,7 @@ data ExamUserCsvAction } | ExamUserCsvSetResultData { examUserCsvActUser :: UserId - , examUserCsvActExamResult :: Maybe (Either ExamResultPassed ExamResultGrade) + , examUserCsvActExamResult :: Maybe ExamResultPassedGrade } | ExamUserCsvSetCourseNoteData { examUserCsvActUser :: UserId @@ -243,8 +243,8 @@ postEUsersR tid ssh csh examn = do showPasses = numSheetsPasses allBoni /= 0 showPoints = getSum (numSheetsPoints allBoni) /= 0 - resultView :: ExamResultGrade -> Either ExamResultPassed ExamResultGrade - resultView = bool (Left . over _examResult (view passingGrade)) Right examShowGrades + resultView :: ExamResultGrade -> ExamResultPassedGrade + resultView = fmap $ bool (Left . view passingGrade) Right examShowGrades let examUsersDBTable = DBTable{..} @@ -319,7 +319,7 @@ postEUsersR tid ssh csh examn = do criteria'' | ExamAttended (ExamPassed True) `Set.member` criteria = criteria' `Set.union` Set.fromList passed - | otherwise + | otherwise = criteria' in queryExamResult row E.?. ExamResultResult `E.in_` E.valList (Just <$> Set.toList criteria'') ) @@ -430,7 +430,7 @@ postEUsersR tid ssh csh examn = do ExamUserCsvCourseRegister -> DBCsvActionNew ExamUserCsvRegister -> DBCsvActionNew ExamUserCsvDeregister -> DBCsvActionMissing - _other -> DBCsvActionExisting + _other -> DBCsvActionExisting , dbtCsvExecuteActions = do C.mapM_ $ \case ExamUserCsvCourseRegisterData{..} -> do @@ -470,7 +470,7 @@ postEUsersR tid ssh csh examn = do deleteBy $ UniqueExamResult eid examUserCsvActUser audit $ TransactionExamResultDeleted eid examUserCsvActUser Just res -> do - let res' = either (over _examResult $ review passingGrade) id res + let res' = either (review passingGrade) id <$> res now <- liftIO getCurrentTime void $ upsertBy (UniqueExamResult eid examUserCsvActUser) @@ -495,7 +495,7 @@ postEUsersR tid ssh csh examn = do ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Just note, .. } -> do now <- liftIO getCurrentTime uid <- liftHandlerT requireAuthId - Entity nid _ <- upsert (CourseUserNote examCourse examUserCsvActUser note) [ CourseUserNoteNote =. note ] + Entity nid _ <- upsert (CourseUserNote examCourse examUserCsvActUser note) [ CourseUserNoteNote =. note ] insert_ $ CourseUserNoteEdit uid now nid return $ CExamR tid ssh csh examn EUsersR , dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case @@ -549,11 +549,7 @@ postEUsersR tid ssh csh examn = do $newline never ^{nameWidget userDisplayName userSurname} $maybe newResult <- examUserCsvActExamResult - $case newResult - $of Left pResult - , _{pResult} - $of Right gResult - , _{gResult} + , _{newResult} $nothing , _{MsgExamResultNone} |] @@ -578,12 +574,12 @@ postEUsersR tid ssh csh examn = do $newline never _{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester} |] - + registeredUserName :: Map (E.Value ExamRegistrationId) ExamUserTableData -> ExamRegistrationId -> Widget registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname where Entity _ User{..} = view resultUser $ existing ! registration - + guessUser :: ExamUserTableCsv -> DB (Bool, UserId) guessUser ExamUserTableCsv{..} = $cachedHereBinary (csvEUserMatriculation, csvEUserName, csvEUserSurname) $ do users <- E.select . E.from $ \user -> do @@ -616,30 +612,40 @@ postEUsersR tid ssh csh examn = do lookupStudyFeatures :: ExamUserTableCsv -> DB (Maybe StudyFeaturesId) lookupStudyFeatures csv@ExamUserTableCsv{..} = do uid <- view _2 <$> guessUser csv - studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) -> do - E.on $ studyTerms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField - E.on $ studyDegree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree - E.where_ . E.and $ catMaybes - [ do - field <- csvEUserField - return . E.or $ catMaybes - [ Just $ studyTerms E.^. StudyTermsName `E.ciEq` E.just (E.val field) - , Just $ studyTerms E.^. StudyTermsShorthand `E.ciEq` E.just (E.val field) - , (studyTerms E.^. StudyTermsKey E.==.) . E.val <$> readMay field - ] - , do - degree <- csvEUserDegree - return . E.or $ catMaybes - [ Just $ studyDegree E.^. StudyDegreeName `E.ciEq` E.just (E.val degree) - , Just $ studyDegree E.^. StudyDegreeShorthand `E.ciEq` E.just (E.val degree) - , (studyDegree E.^. StudyDegreeKey E.==.) . E.val <$> readMay degree - ] - , (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvEUserSemester - ] - E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid - E.&&. studyFeatures E.^. StudyFeaturesValid E.==. E.val True - E.limit 2 - return $ studyFeatures E.^. StudyFeaturesId + oldFeatures <- getBy $ UniqueParticipant uid examCourse + studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) -> + E.distinctOnOrderBy [ E.asc (studyFeatures E.^. StudyFeaturesField) + , E.asc (studyFeatures E.^. StudyFeaturesDegree) + , E.asc (studyFeatures E.^. StudyFeaturesSemester)] $ do + E.on $ studyTerms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField + E.on $ studyDegree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree + E.where_ . E.and $ catMaybes + [ do + field <- csvEUserField + return . E.or $ catMaybes + [ Just $ studyTerms E.^. StudyTermsName `E.ciEq` E.just (E.val field) + , Just $ studyTerms E.^. StudyTermsShorthand `E.ciEq` E.just (E.val field) + , (studyTerms E.^. StudyTermsKey E.==.) . E.val <$> readMay field + ] + , do + degree <- csvEUserDegree + return . E.or $ catMaybes + [ Just $ studyDegree E.^. StudyDegreeName `E.ciEq` E.just (E.val degree) + , Just $ studyDegree E.^. StudyDegreeShorthand `E.ciEq` E.just (E.val degree) + , (studyDegree E.^. StudyDegreeKey E.==.) . E.val <$> readMay degree + ] + , (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvEUserSemester + ] + E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid + let isActive = studyFeatures E.^. StudyFeaturesValid E.==. E.val True + isActiveOrPrevious = case oldFeatures of + Just (Entity _ CourseParticipant{courseParticipantField = Just sfid}) + -> isActive E.||. (E.val sfid E.==. studyFeatures E.^. StudyFeaturesId) + _ -> isActive + E.where_ isActiveOrPrevious -- either active studyFeature or the one previously associated with this course + E.orderBy [E.desc isActiveOrPrevious, E.asc (E.orderByOrd $ studyFeatures E.^. StudyFeaturesType)] + E.limit 2 -- we just need to know whether there is a unique one, none, or more than one + return $ studyFeatures E.^. StudyFeaturesId case studyFeatures of [E.Value fid] -> return $ Just fid _other @@ -647,6 +653,11 @@ postEUsersR tid ssh csh examn = do , is _Nothing csvEUserDegree , is _Nothing csvEUserSemester -> return Nothing + _other + | Just (Entity _ CourseParticipant{..}) <- oldFeatures + , Just sfid <- courseParticipantField + , E.Value sfid `elem` studyFeatures + -> return Nothing _other -> throwM ExamUserCsvExceptionNoMatchingStudyFeatures examUsersDBTableValidator = def & defaultSorting [SortAscBy "user-name"] diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index e4d03153e..5ee6ba68f 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -181,7 +181,7 @@ getSheetListR tid ssh csh = do let hasSFT :: (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool) -> [SheetFileType] hasSFT (E.Value hasExercise, E.Value hasHint, E.Value hasSolution, E.Value hasMarking) - = [ sft | sft <- [minBound..maxBound] + = [ sft | sft <- universeF , sft /= SheetExercise || hasExercise , sft /= SheetHint || hasHint , sft /= SheetSolution || hasSolution @@ -199,7 +199,7 @@ getSheetListR tid ssh csh = do E.where_ $ sheet E.^. SheetCourse E.==. E.val cid sheetFilter :: SheetName -> DB Bool - sheetFilter sheetName = (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False + sheetFilter sheetName = hasReadAccessTo $ CSheetR tid ssh csh sheetName SShowR sheetCol = widgetColonnade . mconcat $ [ -- dbRow , @@ -215,9 +215,9 @@ getSheetListR tid ssh csh = do | let existingSFTs = hasSFT existFiles , sft <- [minBound..maxBound] , let link = CSheetR tid ssh csh sheetName $ SZipR sft - , let icn = toWidget $ sheetFile2markup sft + , let icn = toWgt $ sheetFile2markup sft , let icnCell = if sft `elem` existingSFTs - then linkEmptyCell link icn + then linkEitherCell link (icn, [whamlet| |]) else spacerCell ] id & cellAttrs <>~ [("class","list--inline list--space-separated")] , sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom) diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index fa230101e..21f140921 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -13,10 +13,6 @@ import Data.CaseInsensitive (original) -- import qualified Data.CaseInsensitive as CI import qualified Data.Conduit.List as Conduit -import Language.Haskell.TH -import Language.Haskell.TH.Syntax (qRunIO) --- import Language.Haskell.TH.Datatype - import Text.Hamlet (shamletFile) import Handler.Utils.DateTime as Handler.Utils @@ -30,12 +26,9 @@ import Handler.Utils.Rating as Handler.Utils hiding (extractRatings) import Handler.Utils.Sheet as Handler.Utils import Handler.Utils.Mail as Handler.Utils import Handler.Utils.ContentDisposition as Handler.Utils +import Handler.Utils.I18n as Handler.Utils -import System.Directory (listDirectory) -import System.FilePath.Posix (takeBaseName, takeFileName) - -import qualified Data.List as List -import qualified Data.List.NonEmpty as NonEmpty +import System.FilePath.Posix (takeFileName) import Control.Monad.Logger @@ -216,36 +209,6 @@ warnTermDays tid timeNames = do forM_ outoflecture $ warnI MsgDayIsOutOfLecture forM_ outoftermdays $ warnI MsgDayIsOutOfTerm --- | Add language dependent template files --- --- For large files which are translated as a whole. --- --- Argument musst be a directory under @/templates@, --- which contains a file for each language, --- eg. @imprint@ for choosing between --- @/templates/imprint/de.hamlet@, @/templates/imprint/de-at.hamlet@, --- and @/templates/imprint/en.hamlet@ --- --- Dependency detection cannot work properly (no `addDependentFile`-equivalent --- for directories) --- @$ stack clean@ is required so new translations show up -i18nWidgetFile :: FilePath -> Q Exp -i18nWidgetFile basename = do - -- Construct list of available translations (@de@, @en@, ...) at compile time - let i18nDirectory = "templates" "i18n" basename - availableFiles <- qRunIO $ listDirectory i18nDirectory - let availableTranslations = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . List.nub $ pack . takeBaseName <$> availableFiles - availableTranslations' <- maybe (fail $ "‘" <> i18nDirectory <> "’ is empty") return $ NonEmpty.nonEmpty availableTranslations - - -- Dispatch to correct language (depending on user settings via `selectLanguage`) at run time - ws <- newName "ws" -- Name for dispatch function - letE - [ funD ws $ [ clause [litP $ stringL l] (normalB . widgetFile $ "i18n" basename l) [] - | l <- unpack <$> NonEmpty.toList availableTranslations' -- One function definition for every available language - ] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match - ] [e|selectLanguage availableTranslations' >>= $(varE ws)|] - - -- | return a value only if the current user ist authorized for a given route guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadLogger h diff --git a/src/Handler/Utils/I18n.hs b/src/Handler/Utils/I18n.hs new file mode 100644 index 000000000..1119191d2 --- /dev/null +++ b/src/Handler/Utils/I18n.hs @@ -0,0 +1,43 @@ +module Handler.Utils.I18n + where + +import Import + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (qRunIO) + +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty + +import System.Directory (listDirectory) +import System.FilePath.Posix (takeBaseName) + + +-- | Add language dependent template files +-- +-- For large files which are translated as a whole. +-- +-- Argument musst be a directory under @/templates@, +-- which contains a file for each language, +-- eg. @imprint@ for choosing between +-- @/templates/imprint/de.hamlet@, @/templates/imprint/de-at.hamlet@, +-- and @/templates/imprint/en.hamlet@ +-- +-- Dependency detection cannot work properly (no `addDependentFile`-equivalent +-- for directories) +-- @$ stack clean@ is required so new translations show up +i18nWidgetFile :: FilePath -> Q Exp +i18nWidgetFile basename = do + -- Construct list of available translations (@de@, @en@, ...) at compile time + let i18nDirectory = "templates" "i18n" basename + availableFiles <- qRunIO $ listDirectory i18nDirectory + let availableTranslations = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . List.nub $ pack . takeBaseName <$> availableFiles + availableTranslations' <- maybe (fail $ "‘" <> i18nDirectory <> "’ is empty") return $ NonEmpty.nonEmpty availableTranslations + + -- Dispatch to correct language (depending on user settings via `selectLanguage`) at run time + ws <- newName "ws" -- Name for dispatch function + letE + [ funD ws $ [ clause [litP $ stringL l] (normalB . widgetFile $ "i18n" basename l) [] + | l <- unpack <$> NonEmpty.toList availableTranslations' -- One function definition for every available language + ] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match + ] [e|selectLanguage availableTranslations' >>= $(varE ws)|] \ No newline at end of file diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 7fdeb9ea8..1b7cd74d8 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -44,6 +44,7 @@ import Handler.Utils.Table.Pagination.CsvColumnExplanations import Handler.Utils.Form import Handler.Utils.Csv import Handler.Utils.ContentDisposition +import Handler.Utils.I18n import Utils import Utils.Lens @@ -302,7 +303,7 @@ piIsUnset PaginationInput{..} = and , isNothing piPage ] - + data DBCsvActionMode = DBCsvActionNew | DBCsvActionExisting | DBCsvActionMissing deriving (Read, Show, Eq, Ord, Enum, Bounded, Generic, Typeable) instance Universe DBCsvActionMode @@ -863,6 +864,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db , formSubmit = FormSubmit , formAnchor = Nothing :: Maybe Text } + csvImportExplanation = modal [whamlet|_{MsgCsvImportExplanationLabel}|] $ Right $(i18nWidgetFile "table/csv-import-explanation") csvColExplanations = case dbtCsvEncode of (Just (Dict, _) :: DBTCsvEncode _ csv) -> assertM' (not . null) . Map.toList . csvColumnsExplanations $ Proxy @csv Nothing -> Nothing @@ -933,7 +935,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db | otherwise -> return $ DBCsvDiffNew rowKey row mapM_ fileSourceCsv dbCsvFiles .| C.mapM toDiff - + seen <- State.get forM_ (Map.toList existing) $ \(rowKey, oldRow) -> if | Map.member rowKey seen -> return () @@ -950,7 +952,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db -> let doHandle | Just inpCsv <- x ^? _dbCsvNew = handle $ throwM . (DBCsvException (toNamedRecord inpCsv) :: Text -> DBCsvException k') <=< dbtCsvRenderException - | otherwise + | otherwise = id in C.sourceList <=< lift . doHandle . runConduit $ dbtCsvComputeActions x .| C.foldMap pure innerAct .| C.fold accActionMap Map.empty @@ -966,7 +968,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db let precomputeIdents :: forall f m'. (Eq (Element f), MonoFoldable f, MonadHandler m') => f -> m' (Element f -> Text) - precomputeIdents = foldM (\f act -> (\id' x -> bool (f x) id' $ act == x) <$> newIdent) (\_ -> error "No id precomputed") + precomputeIdents = foldM (\f act -> (\id' x -> bool (f x) id' $ act == x) <$> newIdent) (\_ -> error "No id precomputed") actionClassIdent <- precomputeIdents $ Map.keys actionMap actionIdent <- precomputeIdents . Set.unions $ Map.elems actionMap @@ -992,7 +994,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db , formSubmit = FormSubmit , formAnchor = Nothing :: Maybe Text } - + $(widgetFile "csv-import-confirmation-wrapper") let defaultHeaderOrder = headerOrder (error "not to be forced" :: csv) diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index ac8d8058d..c829532b4 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -19,7 +19,7 @@ import Utils.Lens.TH import qualified Data.Csv as Csv import Database.Persist.Sql - + data ExamResult' res = ExamAttended { examResult :: res } | ExamNoShow @@ -210,14 +210,16 @@ pathPieceJSONKey ''ExamPassed passingGrade :: Iso' ExamGrade ExamPassed -- ^ Improper isomorphism; maps @ExamPassed True@ to `Grade10` passingGrade = iso (ExamPassed . (>= Grade40)) (bool Grade50 Grade10 . examPassed) - + type ExamResultPoints = ExamResult' Points type ExamResultGrade = ExamResult' ExamGrade type ExamResultPassed = ExamResult' ExamPassed -instance Csv.ToField (Either ExamResultPassed ExamResultGrade) where +type ExamResultPassedGrade = ExamResult' (Either ExamPassed ExamGrade) + +instance Csv.ToField (Either ExamPassed ExamGrade) where toField = either Csv.toField Csv.toField -instance Csv.FromField (Either ExamResultPassed ExamResultGrade) where +instance Csv.FromField (Either ExamPassed ExamGrade) where parseField x = (Left <$> Csv.parseField x) <|> (Right <$> Csv.parseField x) -- encodings are disjoint diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index d7fee3e25..f21c55ecb 100644 --- a/src/Model/Types/Misc.hs +++ b/src/Model/Types/Misc.hs @@ -18,6 +18,8 @@ import qualified Data.Text.Lens as Text data StudyFieldType = FieldPrimary | FieldSecondary deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic) derivePersistField "StudyFieldType" +instance Universe StudyFieldType +instance Finite StudyFieldType data Theme diff --git a/stack.yaml.lock b/stack.yaml.lock index cb8c9d974..45c694d00 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -10,13 +10,13 @@ packages: sha256: 2cab90bba4d15bf6a17e3cb8e50bc8708c1091de503dd4e91d3954240e89f37b name: zip-stream version: 0.1.0.1 - git: https://github.com/pngwjpgh/zip-stream.git + git: https://github.com/uni2work/zip-stream.git pantry-tree: size: 657 sha256: d1626bbc3fb88a48ce9c5c37199f8cbf426be6410740891d76a8343de4f3c109 commit: 9272bbed000928d500febad1cdc98d1da29d399e original: - git: https://github.com/pngwjpgh/zip-stream.git + git: https://github.com/uni2work/zip-stream.git commit: 9272bbed000928d500febad1cdc98d1da29d399e - completed: cabal-file: @@ -24,13 +24,13 @@ packages: sha256: 88537113b855381b8d70da2442ae644dc979ad6b32aaaec2ebf55306764c8f1a name: encoding version: 0.8.2 - git: https://github.com/pngwjpgh/encoding.git + git: https://github.com/uni2work/encoding.git pantry-tree: size: 5668 sha256: 57160d758802aba6a0d2cc88c53f2f0bb60df7d5e6822938351618b7eca0beab commit: 67bb87ceff53f0178c988dd4e15eeb2daee92b84 original: - git: https://github.com/pngwjpgh/encoding.git + git: https://github.com/uni2work/encoding.git commit: 67bb87ceff53f0178c988dd4e15eeb2daee92b84 - completed: cabal-file: @@ -38,13 +38,13 @@ packages: sha256: 7b25a0ef819e8a01b485d6d0865baa3445faa826ffb3876c94109dd2469ffbd3 name: memcached-binary version: 0.2.0 - git: https://github.com/pngwjpgh/memcached-binary.git + git: https://github.com/uni2work/memcached-binary.git pantry-tree: size: 1170 sha256: c466f91129410bae1f53e25aec4026f6984ce2dff0ada4516e2548048aba549a commit: b5461747e7be226d3b67daebc3c9aefe8a4490ad original: - git: https://github.com/pngwjpgh/memcached-binary.git + git: https://github.com/uni2work/memcached-binary.git commit: b5461747e7be226d3b67daebc3c9aefe8a4490ad - completed: hackage: colonnade-1.2.0@sha256:5620e999a68a394abfe157da6302dd6d8ce8a89b527ea9c294519efd7c4edb2c,2092 diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index f929425ec..577e95c01 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -482,6 +482,11 @@ ul.list--inline { } } +.list--icon-width li { + width: 1rem; + height: 1rem; +} + /* DEFINITION LIST */ .deflist { display: grid; @@ -626,7 +631,7 @@ section { grid-column: 1; max-width: none; - + padding-left: 40px; &::before { diff --git a/templates/i18n/table/csv-import-explanation/de.hamlet b/templates/i18n/table/csv-import-explanation/de.hamlet new file mode 100644 index 000000000..ba415fd30 --- /dev/null +++ b/templates/i18n/table/csv-import-explanation/de.hamlet @@ -0,0 +1,37 @@ +

Hinweise zum Import von CSV-Dateien +
+
Änderungen +
+ Einige Zellen können durch den Import verändert werden. + Nicht-änderbare Zellen werden ignoriert, falls diese verändert wurden. +
Vorschau +
+ Es wird eine Vorschau angezeigt, bevor irgendetwas tatsächlich geändert wird. + In der Vorschau können dann auch nur teilweise Änderungen ausgewählt werden. +
Leere Zellen +
+ Löschbare Zellen werden durch leere Zellen gelöscht oder auf eindeutige Werte gesetzt. +
Konsistenz +
+

+ Es werden nur konsistente Änderungen akzeptiert! +

+ Daraus folgt, dass es sinnvoll sein kann, gewisse Zellen frei zu lassen; + z.B. ändert man ein Studienfachzuordnung eines Teilnehmers ab, + dann müsste man auch Abschluss und Semesterzahl passend ändern. + Da diese jedoch eindeutig sind, kann man diese Zellen einfach frei lassen. +

Zeilen Identifikation +
+ Mehrere Spalten werden zur Identifikation der Zeile verwendet. + Es muss nicht in jeder Spalte der Zeile ein Wert vorhanden sein, + so lange die Identifikation noch eindeutig ist. + Sind mehrere Werte vorhanden, so müssen diese natürlich zueinander passen. +
Zeilen hinzufügen +
+ Es können auch neue Zeilen hinzugefügt werden, so fern ausreichend + eindeutige Informationen vorhanden sind; + z.B. können so Prüfungsteilnehmer nachgemeldet werden. +
Zeilen löschen +
+ Fehlende Zeilen werden in der Vorschau zur Löschung angeboten + und dann ggf. gelöscht. diff --git a/templates/table/csv-transcode.hamlet b/templates/table/csv-transcode.hamlet index 11586a227..92e1ea95a 100644 --- a/templates/table/csv-transcode.hamlet +++ b/templates/table/csv-transcode.hamlet @@ -4,11 +4,15 @@ $if is _Just dbtCsvDecode

_{MsgTableHeadingCsvImport}
+

+ ^{csvImportExplanation} ^{csvImportWdgt'} $if is _Just dbtCsvEncode

_{MsgTableHeadingCsvExport}
+

+ ^{csvColExplanations'} ^{csvExportWdgt'} - ^{csvColExplanations'} + diff --git a/templates/table/csv-transcode.lucius b/templates/table/csv-transcode.lucius index 7c6de1c2a..bcf12df47 100644 --- a/templates/table/csv-transcode.lucius +++ b/templates/table/csv-transcode.lucius @@ -1,19 +1,6 @@ .csv-export { margin-bottom: 13px; - - .csv-export__content { - display: flex; - align-content: space-between; - align-items: center; - & > * { - margin-right: 10px; - - &:last-child { - margin-right: 0; - } - } - } } .csv-import {