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

Merge branch 'master' into 155-zentralanmeldungen

Browse Source
This commit is contained in:
Gregor Kleen 2019-08-22 15:29:07 +02:00
commit 104ab8f994
20 changed files with 239 additions and 132 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
.vscode/tasks.json vendored
View File

@ -69,6 +69,11 @@
"type": "npm",
"script": "lint",
"problemMatcher": []
},
{
"type": "npm",
"script": "release",
"problemMatcher": []
}
]
}

40
CHANGELOG.md
View File

@ -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)

9
messages/uniworx/de.msg
View File

@ -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)}%)

2
package-lock.json generated
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "5.1.0",
"version": "5.2.3",
"lockfileVersion": 1,
"requires": true,
"dependencies": {

2
package.json
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "5.1.0",
"version": "5.2.3",
"description": "",
"keywords": [],
"author": "",

2
package.yaml
View File

@ -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

10
routes
View File

@ -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

11
src/Foundation.hs
View File

@ -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

99
src/Handler/Exam/Users.hs
View File

@ -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"]

8
src/Handler/Sheet.hs
View File

@ -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|&emsp;|])
else spacerCell
] id & cellAttrs <>~ [("class","list--inline list--space-separated")]
, sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)

41
src/Handler/Utils.hs
View File

@ -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

43
src/Handler/Utils/I18n.hs Normal file
View File

@ -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)|]

12
src/Handler/Utils/Table/Pagination.hs
View File

@ -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)

10
src/Model/Types/Exam.hs
View File

@ -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

2
src/Model/Types/Misc.hs
View File

@ -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

12
stack.yaml.lock
View File

@ -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

7
templates/default-layout.lucius
View File

@ -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 {

37
templates/i18n/table/csv-import-explanation/de.hamlet Normal file
View File

@ -0,0 +1,37 @@
<h3>Hinweise zum Import von CSV-Dateien
<dl .deflist>
<dt .deflist__dt>Änderungen
<dd .deflist__dd>
Einige Zellen können durch den Import verändert werden.
Nicht-änderbare Zellen werden ignoriert, falls diese verändert wurden.
<dt .deflist__dt>Vorschau
<dd .deflist__dd>
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.
<dt .deflist__dt>Leere Zellen
<dd .deflist__dd>
Löschbare Zellen werden durch leere Zellen gelöscht oder auf eindeutige Werte gesetzt.
<dt .deflist__dt>Konsistenz
<dd .deflist__dd>
<p>
Es werden nur konsistente Änderungen akzeptiert!
<p>
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.
<dt .deflist__dt>Zeilen Identifikation
<dd .deflist__dd>
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.
<dt .deflist__dt>Zeilen hinzufügen
<dd .deflist__dd>
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.
<dt .deflist__dt>Zeilen löschen
<dd .deflist__dd>
Fehlende Zeilen werden in der Vorschau zur Löschung angeboten
und dann ggf. gelöscht.

6
templates/table/csv-transcode.hamlet
View File

@ -4,11 +4,15 @@ $if is _Just dbtCsvDecode
<h3 .csv-import__toggle uw-show-hide data-show-hide-id=table-csv-import data-show-hide-collapsed>
_{MsgTableHeadingCsvImport}
<div .csv-import__content>
<p>
^{csvImportExplanation}
^{csvImportWdgt'}
$if is _Just dbtCsvEncode
<div .csv-export>
<h3 .csv-import__toggle uw-show-hide data-show-hide-id=table-csv-export>
_{MsgTableHeadingCsvExport}
<div .csv-export__content>
<p>
^{csvColExplanations'}
^{csvExportWdgt'}
^{csvColExplanations'}

13
templates/table/csv-transcode.lucius
View File

@ -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 {