From d3375bb2c150611e891d883674831ede574ad346 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Wed, 18 Sep 2019 13:21:42 +0200 Subject: [PATCH 01/38] fix(datepicker): select time from preselected date on edit --- frontend/src/utils/form/datepicker.js | 34 +++++++++------------------ 1 file changed, 11 insertions(+), 23 deletions(-) diff --git a/frontend/src/utils/form/datepicker.js b/frontend/src/utils/form/datepicker.js index 11d7394bc..c116e8ea6 100644 --- a/frontend/src/utils/form/datepicker.js +++ b/frontend/src/utils/form/datepicker.js @@ -24,17 +24,6 @@ const FORM_DATE_FORMAT_MOMENT = { 'datetime-local': `${FORM_DATE_FORMAT_DATE_MOMENT} ${FORM_DATE_FORMAT_TIME_MOMENT}`, }; -/** - * Takes a string representation of a date and a format string and parses the given date to a Date object. - * If the date string is not valid (i.e. cannot be parsed with the given format string), returns undefined. - * @param {*} dateStr string representation of a date - * @param {*} dateFormat format string of the date - */ -function parseDateWithFormat(dateStr, dateFormat) { - const parsedMomentDate = moment(dateStr, dateFormat); - if (parsedMomentDate.isValid()) return parsedMomentDate.toDate(); -} - /** * Takes a string representation of a date, an input ('previous') format and a desired output format and returns a reformatted date string. * If the date string is not valid (i.e. cannot be parsed with the given input format string), returns the original date string; @@ -136,6 +125,9 @@ export class Datepicker { throw new Error('Datepicker utility called on unsupported element!'); } + // format any existing dates to fancy display format on pageload + this.formatElementValue(true); + // initialize tail.datetime (datepicker) instance this.datepickerInstance = datetime(this._element, { ...datepickerGlobalConfig, ...datepickerConfig }); @@ -187,9 +179,6 @@ export class Datepicker { // format the date value of the form input element of this datepicker before form submission this._element.form.addEventListener('submit', () => this.formatElementValue()); - - // format any existing dates to fancy display format on pageload - this.formatElementValue(true); } destroy() { @@ -201,22 +190,21 @@ export class Datepicker { * @param {*} toFancy optional target format switch (boolean value; default is false). If set to a truthy value, formats the element value to fancy instead of internal date format. */ formatElementValue(toFancy) { - const dp = this.datepickerInstance; if (this._element.value) { - if (toFancy) { - const parsedDate = parseDateWithFormat(this._element.value, FORM_DATE_FORMAT[this.elementType]); - if (parsedDate) dp.selectDate(); - } else { - this._element.value = this.unformat(); - } + this._element.value = this.unformat(toFancy); } } + + /** * Returns a datestring in internal format from the current state of the input element value. + * @param {*} toFancy Format date from internal to fancy or vice versa. When omitted, toFancy is falsy and results in fancy -> internal */ - unformat() { - return reformatDateString(this._element.value, FORM_DATE_FORMAT_MOMENT[this.elementType], FORM_DATE_FORMAT[this.elementType]); + unformat(toFancy) { + const formatIn = toFancy ? FORM_DATE_FORMAT[this.elementType] : FORM_DATE_FORMAT_MOMENT[this.elementType]; + const formatOut = toFancy ? FORM_DATE_FORMAT_MOMENT[this.elementType] : FORM_DATE_FORMAT[this.elementType]; + return reformatDateString(this._element.value, formatIn, formatOut); } /** From 756fa492e3da0ceef7712b01e0290124f20e1245 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 25 Sep 2019 15:01:55 +0200 Subject: [PATCH 02/38] chore: bump process for stack >=2 --- stack.yaml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/stack.yaml b/stack.yaml index 613d3543a..46618df8e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -56,5 +56,7 @@ extra-deps: - persistent-qq-2.9.1 + - process-1.6.5.1 + resolver: lts-13.21 allow-newer: true From 0241cda78a82bb04f15923d5d76a6ec637307a47 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 25 Sep 2019 17:36:18 +0200 Subject: [PATCH 03/38] chore: allow building of specific haddocks --- haddock.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock.sh b/haddock.sh index 13bb626e0..00308065f 100755 --- a/haddock.sh +++ b/haddock.sh @@ -15,4 +15,4 @@ if [[ -d .stack-work-doc ]]; then trap move-back EXIT fi -stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal +stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal ${@} From 7a2b972f9f78817688b344ac269ba99694f0854a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 25 Sep 2019 17:36:48 +0200 Subject: [PATCH 04/38] fix(communication): make communication form more intuitive Fixes #387 --- messages/uniworx/de.msg | 2 + src/Handler/Sheet.hs | 6 +-- src/Handler/Utils/Communication.hs | 10 ++-- src/Handler/Utils/Csv.hs | 41 +---------------- src/Import/NoModel.hs | 4 ++ src/Jobs/Handler/SendCourseCommunication.hs | 12 ++--- src/Mail.hs | 43 +++++++++++++---- src/Network/Mail/Mime/Instances.hs | 12 +++++ src/Settings.hs | 18 +------- src/Settings/Mime.hs | 31 +++++++++++++ src/Utils/Csv.hs | 51 ++++++++++++++++++++- 11 files changed, 151 insertions(+), 79 deletions(-) create mode 100644 src/Settings/Mime.hs diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 8a24388d0..41e50c599 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1135,8 +1135,10 @@ NavigationFavourites: Favoriten CommSubject: Betreff CommBody: Nachricht +CommBodyTip: Das Eingabefeld akzeptiert derzeit ausschließlich Html. U.A. Zeilumbrüche werden dementsprechend ignoriert und müssen manuell mit
eingefügt werden. CommRecipients: Empfänger CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht +CommRecipientsList: Die an Sie selbst verschickte Kopie der Nachricht wird, zu Archivierungszwecken, eine vollständige Liste aller Empfänger enthalten. Die Empfängerliste wird im CSV-Format and die E-Mail angehängt. Andere Empfänger erhalten die Liste nicht. Bitte entfernen Sie dementsprechend den Anhang bevor Sie die E-Mail weiterleiten oder anderweitig mit Dritten teilen. CommDuplicateRecipients n@Int: #{n} #{pluralDE n "doppelter" "doppelte"} Empfänger ignoriert CommSuccess n@Int: Nachricht wurde an #{n} Empfänger versandt diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 06d200c2a..7d521389f 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -686,7 +686,7 @@ defaultLoads shid = do return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad, sheetCorrector E.^. SheetCorrectorState) where toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads - toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton (Right uid) (state, load) + toMap = foldMap $ \(E.Value uid, E.Value cLoad, E.Value cState) -> Map.singleton (Right uid) (cState, cLoad) correctorForm :: SheetId -> AForm Handler (Set (Either (Invitation' SheetCorrector) SheetCorrector)) @@ -809,7 +809,7 @@ correctorForm shid = wFormToAForm $ do postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> Either (Invitation' SheetCorrector) SheetCorrector postProcess' (Right sheetCorrectorUser, (sheetCorrectorState, sheetCorrectorLoad)) = Right SheetCorrector{..} - postProcess' (Left email, (state, load)) = Left (email, shid, (InvDBDataSheetCorrector load state, InvTokenDataSheetCorrector)) + postProcess' (Left email, (cState, load)) = Left (email, shid, (InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector)) filledData :: Maybe (Map ListPosition (Either UserEmail UserId, (CorrectorState, Load))) filledData = Just . Map.fromList . zip [0..] $ Map.toList loads -- TODO orderBy Name?! @@ -906,7 +906,7 @@ correctorInvitationConfig = InvitationConfig{..} itAuthority <- liftHandler requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized - invitationForm _ (InvDBDataSheetCorrector load state, _) _ = pure $ (JunctionSheetCorrector load state, ()) + invitationForm _ (InvDBDataSheetCorrector cLoad cState, _) _ = pure $ (JunctionSheetCorrector cLoad cState, ()) invitationInsertHook _ _ _ _ = id invitationSuccessMsg (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName invitationUltDest (Entity _ Sheet{..}) _ = do diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 933730346..da9ed5a2e 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -150,9 +150,9 @@ commR CommunicationRoute{..} = do -> Map (EnumPosition RecipientCategory, ListPosition) (FieldView UniWorX) -> Map (Natural, (EnumPosition RecipientCategory, ListPosition)) Widget -> Widget - miLayout liveliness state cellWdgts _delButtons addWdgts = do + miLayout liveliness cState cellWdgts _delButtons addWdgts = do checkedIdentBase <- newIdent - let checkedCategories = Set.mapMonotonic (unEnumPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False state) $ Map.keysSet state + let checkedCategories = Set.mapMonotonic (unEnumPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False cState) $ Map.keysSet cState checkedIdent c = checkedIdentBase <> "-" <> toPathPiece c hasContent c = not (null $ categoryIndices c) || Map.member (1, (EnumPosition c, 0)) addWdgts categoryIndices c = Set.filter ((== c) . unEnumPosition . fst) $ review liveCoords liveliness @@ -165,10 +165,13 @@ commR CommunicationRoute{..} = do postProcess :: Map (EnumPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId) postProcess = Set.fromList . map fst . filter snd . Map.elems + recipientsListMsg <- messageI Info MsgCommRecipientsList + ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . renderAForm FormStandard $ Communication <$> recipientAForm + <* aformMessage recipientsListMsg <*> aopt textField (fslI MsgCommSubject) Nothing - <*> areq htmlField (fslpI MsgCommBody "Html") Nothing + <*> areq htmlField (fslpI MsgCommBody "Html" & setTooltip MsgCommBodyTip) Nothing formResult commRes $ \comm -> do runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs addMessageI Success . MsgCommSuccess . Set.size $ cRecipients comm @@ -183,4 +186,3 @@ commR CommunicationRoute{..} = do siteLayoutMsg crHeading $ do setTitleI crHeading formWdgt - $(i18nWidgetFile "html-input") diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index 89e4f1f70..ff84ddfb9 100644 --- a/src/Handler/Utils/Csv.hs +++ b/src/Handler/Utils/Csv.hs @@ -1,8 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Handler.Utils.Csv - ( typeCsv, extensionCsv - , decodeCsv + ( decodeCsv , encodeCsv , encodeDefaultOrderedCsv , respondCsv, respondCsvDB @@ -12,9 +11,6 @@ module Handler.Utils.Csv , ToNamedRecord(..), FromNamedRecord(..) , DefaultOrdered(..) , ToField(..), FromField(..) - , CsvRendered(..) - , toCsvRendered - , toDefaultOrderedCsvRendered ) where import Import hiding (Header, mapM_) @@ -40,18 +36,6 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.Attoparsec.ByteString.Lazy as A -deriving instance Typeable CsvParseError -instance Exception CsvParseError - - -typeCsv, typeCsv' :: ContentType -typeCsv = simpleContentType typeCsv' -typeCsv' = "text/csv; charset=UTF-8; header=present" - -extensionCsv :: Extension -extensionCsv = fromMaybe "csv" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeCsv ] - - decodeCsv :: (MonadThrow m, FromNamedRecord csv, MonadLogger m) => ConduitT ByteString csv m () decodeCsv = transPipe throwExceptT $ do testBuffer <- accumTestBuffer LBS.empty @@ -173,11 +157,6 @@ fileSourceCsv :: ( FromNamedRecord csv fileSourceCsv = (.| decodeCsv) . fileSource -data CsvRendered = CsvRendered - { csvRenderedHeader :: Header - , csvRenderedData :: [NamedRecord] - } deriving (Eq, Read, Show, Generic, Typeable) - instance ToWidget UniWorX CsvRendered where toWidget CsvRendered{..} = liftWidget $(widgetFile "widgets/csvRendered") where @@ -188,21 +167,3 @@ instance ToWidget UniWorX CsvRendered where ] headers = decodeUtf8 <$> Vector.toList csvRenderedHeader - -toCsvRendered :: forall mono. - ( ToNamedRecord (Element mono) - , MonoFoldable mono - ) - => Header - -> mono -> CsvRendered -toCsvRendered csvRenderedHeader (otoList -> csvs) = CsvRendered{..} - where - csvRenderedData = map toNamedRecord csvs - -toDefaultOrderedCsvRendered :: forall mono. - ( ToNamedRecord (Element mono) - , DefaultOrdered (Element mono) - , MonoFoldable mono - ) - => mono -> CsvRendered -toDefaultOrderedCsvRendered = toCsvRendered $ headerOrder (error "headerOrder" :: Element mono) diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index f6f8e76bc..bbc0f02d9 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -84,6 +84,10 @@ import Control.Monad.Trans.Reader as Import ( reader, Reader, runReader, mapReader, withReader , ReaderT(..), mapReaderT, withReaderT ) +import Control.Monad.Trans.State as Import + ( state, State, runState, mapState, withState + , StateT(..), mapStateT, withStateT + ) import Control.Monad.Base as Import import Control.Monad.Catch as Import hiding (Handler(..)) import Control.Monad.Trans.Control as Import hiding (embed) diff --git a/src/Jobs/Handler/SendCourseCommunication.hs b/src/Jobs/Handler/SendCourseCommunication.hs index 182ed6cbc..7a35229d0 100644 --- a/src/Jobs/Handler/SendCourseCommunication.hs +++ b/src/Jobs/Handler/SendCourseCommunication.hs @@ -6,8 +6,6 @@ import Import import Handler.Utils -import qualified Data.Set as Set - import qualified Data.CaseInsensitive as CI @@ -26,11 +24,11 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do void $ setMailObjectUUID jMailObjectUUID _mailFrom .= userAddress sender - if -- Use `addMailHeader` instead of `_mailCc` to make `mailT` ignore the additional recipients - | jRecipientEmail == Right jSender - -> addMailHeader "Cc" . intercalate ", " . map renderAddress $ Set.toAscList (Set.delete (userAddress sender) jAllRecipientAddresses) - | otherwise - -> addMailHeader "Cc" "Undisclosed Recipients:;" + addMailHeader "Cc" "Undisclosed Recipients:;" addMailHeader "Auto-Submitted" "no" setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgCommCourseSubject) SomeMessage jSubject void $ addPart jMailContent + when (jRecipientEmail == Right jSender) $ + addPart' $ do + partIsAttachment $ "all-recipients" `addExtension` unpack extensionCsv + toMailPart $ toDefaultOrderedCsvRendered jAllRecipientAddresses diff --git a/src/Mail.hs b/src/Mail.hs index 03d14b83d..60baf72b5 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -21,7 +21,7 @@ module Mail , PrioritisedAlternatives , ToMailPart(..) , addAlternatives, provideAlternative, providePreferredAlternative - , addPart + , addPart, addPart', modifyPart, partIsAttachment , MonadHeader(..) , MailHeader , MailObjectId @@ -43,6 +43,8 @@ import Model.Types.TH.JSON import Network.Mail.Mime hiding (addPart, addAttachment) import qualified Network.Mail.Mime as Mime (addPart) +import Settings.Mime + import Data.Monoid (Last(..)) import Control.Monad.Trans.RWS (RWST(..)) import Control.Monad.Trans.State (StateT(..), execStateT, mapStateT) @@ -71,6 +73,10 @@ import qualified Data.ByteString.Lazy as LBS import Utils (MsgRendererS(..), MonadSecretBox(..), maybeT) import Utils.Lens.TH + +import Utils.Csv (CsvRendered(..), typeCsv') +import qualified Data.Csv as Csv + import Control.Lens hiding (from) import Control.Lens.Extras (is) @@ -336,7 +342,7 @@ instance YesodMail site => ToMailPart site (StateT Part (HandlerFor site) a) whe instance YesodMail site => ToMailPart site LT.Text where toMailPart text = do - _partType .= "text/plain; charset=utf-8" + _partType .= decodeUtf8 typePlain _partEncoding .= QuotedPrintableText _partContent .= encodeUtf8 text @@ -348,7 +354,7 @@ instance YesodMail site => ToMailPart site LTB.Builder where instance YesodMail site => ToMailPart site Html where toMailPart html = do - _partType .= "text/html; charset=utf-8" + _partType .= decodeUtf8 typeHtml _partEncoding .= QuotedPrintableText _partContent .= renderMarkup html @@ -372,10 +378,16 @@ instance ToMailPart site a => ToMailPart site (Shakespeare.RenderUrl (Route site instance YesodMail site => ToMailPart site Aeson.Value where toMailPart val = do - _partType .= "application/json; charset=utf-8" + _partType .= decodeUtf8 typeJson _partEncoding .= QuotedPrintableText _partContent .= Aeson.encodePretty val +instance YesodMail site => ToMailPart site CsvRendered where + toMailPart CsvRendered{..} = do + _partType .= decodeUtf8 typeCsv' + _partEncoding .= QuotedPrintableText + _partContent .= Csv.encodeByName csvRenderedHeader csvRenderedData + addAlternatives :: (MonadMail m) => Writer (PrioritisedAlternatives m) () @@ -396,20 +408,35 @@ addPart :: ( MonadMail m , HandlerSite m ~ site , ToMailPart site a ) => a -> m (MailPartReturn site a) -addPart part = do - (ret, part') <- runStateT (toMailPart part) initialPart +addPart = addPart' . toMailPart + +addPart' :: MonadMail m + => StateT Part m a + -> m a +addPart' part = do + (ret, part') <- runStateT part initialPart modify . Mime.addPart $ pure part' return ret initialPart :: Part initialPart = Part - { partType = "text/plain" - , partEncoding = None + { partType = decodeUtf8 defaultMimeType + , partEncoding = Base64 , partFilename = Nothing , partHeaders = [] , partContent = mempty } +modifyPart :: (MonadMail m, HandlerSite m ~ site, YesodMail site) + => StateT Part (HandlerFor site) a + -> StateT Part m a +modifyPart = toMailPart + +partIsAttachment :: (Textual t, MonadMail m, HandlerSite m ~ site, YesodMail site) + => t + -> StateT Part m () +partIsAttachment (repack -> fName) = modifyPart $ _partFilename .= Just fName + class MonadHandler m => MonadHeader m where modifyHeaders :: (Headers -> Headers) -> m () diff --git a/src/Network/Mail/Mime/Instances.hs b/src/Network/Mail/Mime/Instances.hs index 7861f5c3d..83cc59c14 100644 --- a/src/Network/Mail/Mime/Instances.hs +++ b/src/Network/Mail/Mime/Instances.hs @@ -14,6 +14,8 @@ import Data.Aeson.TH import Utils.PathPiece import Utils (assertM) + +import qualified Data.Csv as Csv deriving instance Read Address @@ -32,3 +34,13 @@ instance FromJSON Address where addressName <- assertM (not . null) <$> (obj .:? "name") addressEmail <- obj .: "email" return Address{..} + + +instance Csv.ToNamedRecord Address where + toNamedRecord Address{..} = Csv.namedRecord + [ "name" Csv..= addressName + , "email" Csv..= addressEmail + ] + +instance Csv.DefaultOrdered Address where + headerOrder _ = Csv.header [ "name", "email" ] diff --git a/src/Settings.hs b/src/Settings.hs index df9bce882..48d70d396 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -9,6 +9,7 @@ module Settings ( module Settings , module Settings.Cluster + , module Settings.Mime ) where import Import.NoModel @@ -58,6 +59,7 @@ import qualified Database.Memcached.Binary.Types as Memcached import Model import Settings.Cluster +import Settings.Mime import Control.Monad.Trans.Maybe (MaybeT(..)) @@ -67,10 +69,6 @@ import Jose.Jwt (JwtEncoding(..)) import System.FilePath.Glob import Handler.Utils.Submission.TH -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 @@ -458,18 +456,6 @@ widgetFileSettings = def submissionBlacklist :: [Pattern] submissionBlacklist = $(patternFile compDefault "config/submission-blacklist") -mimeMap :: MimeMap -mimeMap = $(mimeMapFile "config/mimetypes") - -mimeLookup :: FileName -> MimeType -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/Settings/Mime.hs b/src/Settings/Mime.hs new file mode 100644 index 000000000..afa03594b --- /dev/null +++ b/src/Settings/Mime.hs @@ -0,0 +1,31 @@ +module Settings.Mime + ( mimeMap + , mimeLookup + , mimeExtensions + , archiveTypes + , module Network.Mime + ) where + +import ClassyPrelude + +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Network.Mime + ( FileName, MimeType, MimeMap, Extension + , mimeByExt, defaultMimeType + ) +import Network.Mime.TH + + +mimeMap :: MimeMap +mimeMap = $(mimeMapFile "config/mimetypes") + +mimeLookup :: FileName -> MimeType +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") diff --git a/src/Utils/Csv.hs b/src/Utils/Csv.hs index e864f9e04..0c071f864 100644 --- a/src/Utils/Csv.hs +++ b/src/Utils/Csv.hs @@ -1,14 +1,39 @@ +{-# OPTIONS -fno-warn-orphans #-} + module Utils.Csv - ( pathPieceCsv + ( typeCsv, typeCsv', extensionCsv + , pathPieceCsv , (.:??) + , CsvRendered(..) + , toCsvRendered + , toDefaultOrderedCsvRendered ) where import ClassyPrelude hiding (lookup) +import Settings.Mime + import Data.Csv hiding (Name) +import Data.Csv.Conduit (CsvParseError) import Language.Haskell.TH (Name) import Language.Haskell.TH.Lib +import Yesod.Core.Content (ContentType, simpleContentType) + +import qualified Data.Map as Map + + +deriving instance Typeable CsvParseError +instance Exception CsvParseError + + +typeCsv, typeCsv' :: ContentType +typeCsv = simpleContentType typeCsv' +typeCsv' = "text/csv; charset=UTF-8; header=present" + +extensionCsv :: Extension +extensionCsv = fromMaybe "csv" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeCsv ] + pathPieceCsv :: Name -> DecsQ pathPieceCsv (conT -> t) = @@ -22,3 +47,27 @@ pathPieceCsv (conT -> t) = (.:??) :: FromField (Maybe a) => NamedRecord -> ByteString -> Parser (Maybe a) m .:?? name = lookup m name <|> return Nothing + + +data CsvRendered = CsvRendered + { csvRenderedHeader :: Header + , csvRenderedData :: [NamedRecord] + } deriving (Eq, Read, Show, Generic, Typeable) + +toCsvRendered :: forall mono. + ( ToNamedRecord (Element mono) + , MonoFoldable mono + ) + => Header + -> mono -> CsvRendered +toCsvRendered csvRenderedHeader (otoList -> csvs) = CsvRendered{..} + where + csvRenderedData = map toNamedRecord csvs + +toDefaultOrderedCsvRendered :: forall mono. + ( ToNamedRecord (Element mono) + , DefaultOrdered (Element mono) + , MonoFoldable mono + ) + => mono -> CsvRendered +toDefaultOrderedCsvRendered = toCsvRendered $ headerOrder (error "headerOrder" :: Element mono) From 977840446e5a9b5836c6f7370c6134b144b8902e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 25 Sep 2019 17:43:23 +0200 Subject: [PATCH 05/38] fix: make migration idempotent again --- models/courses | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/models/courses b/models/courses index 758f6980d..260c4254f 100644 --- a/models/courses +++ b/models/courses @@ -20,7 +20,7 @@ Course -- Information about a single course; contained info is always visible applicationsRequired Bool default=false applicationsInstructions Html Maybe applicationsText Bool default=false - applicationsFiles UploadMode "default='{ \"mode\": \"no-upload\" }'::jsonb" + applicationsFiles UploadMode "default='{\"mode\": \"no-upload\"}'::jsonb" applicationsRatingsVisible Bool default=false TermSchoolCourseShort term school shorthand -- shorthand must be unique within school and semester TermSchoolCourseName term school name -- name must be unique within school and semester From 39f12957f55256db74960b47be3797e881c525b8 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 25 Sep 2019 18:01:20 +0200 Subject: [PATCH 06/38] fix: fix startup on unix-socket --- src/Application.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index ab50d34e6..1181b9a9f 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -77,7 +77,7 @@ import System.Posix.Process (getProcessID) import System.Posix.Signals (SignalInfo(..), installHandler, sigTERM) import qualified System.Posix.Signals as Signals (Handler(..)) -import Network.Socket (socketPort) +import Network.Socket (socketPort, Socket, PortNumber) import qualified Network.Socket as Socket (close) import Control.Concurrent.STM.Delay @@ -370,7 +370,7 @@ develMain = runResourceT $ do liftIO . develMainHelper $ return (wsettings, app) -- | The @main@ function for an executable running this site. -appMain :: MonadUnliftIO m => m () +appMain :: forall m. MonadUnliftIO m => m () appMain = runResourceT $ do settings <- getAppSettings @@ -398,7 +398,7 @@ appMain = runResourceT $ do $logInfoS "bind" [st|Listening on #{tshow host} port #{tshow port} as per configuration|] liftIO $ pure <$> bindPortTCP port host - $logDebugS "bind" . tshow =<< mapM (liftIO . socketPort) sockets + $logDebugS "bind" . tshow =<< mapM (liftIO . try . socketPort :: Socket -> _ (Either SomeException PortNumber)) sockets mainThreadId <- myThreadId liftIO . void . flip (installHandler sigTERM) Nothing . Signals.CatchInfo $ \SignalInfo{..} -> runAppLoggingT foundation $ do From cc7a5289a4ef7965b3464bb826e6a1e32a5d2929 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 25 Sep 2019 18:36:39 +0200 Subject: [PATCH 07/38] fix: improve async behaviour --- app/DevelMain.hs | 5 +---- src/Jobs.hs | 11 ++++++++--- src/Utils/Sql.hs | 17 ++++++++++------- 3 files changed, 19 insertions(+), 14 deletions(-) diff --git a/app/DevelMain.hs b/app/DevelMain.hs index 0a7a89562..ab065aaa2 100644 --- a/app/DevelMain.hs +++ b/app/DevelMain.hs @@ -77,10 +77,7 @@ update = do (port, site, app) <- getApplicationRepl resourceForkIO $ do finally (liftIO $ runSettings (setPort port defaultSettings) app) - -- Note that this implies concurrency - -- between shutdownApp and the next app that is starting. - -- Normally this should be fine - (liftIO $ putMVar done () >> shutdownApp site) + (liftIO $ shutdownApp site >> putMVar done ()) -- | kill the server shutdown :: IO () diff --git a/src/Jobs.hs b/src/Jobs.hs index c65410dc0..39a1d7bac 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -55,8 +55,6 @@ import Data.Time.Zones import Control.Concurrent.STM (retry) import Control.Concurrent.STM.Delay -import UnliftIO.Concurrent (forkIO) - import Jobs.Handler.SendNotification import Jobs.Handler.SendTestEmail @@ -143,6 +141,9 @@ manageJobPool foundation@UniWorX{..} spawnMissingWorkers, reapDeadWorkers, terminateGracefully :: STM (ContT () m ()) spawnMissingWorkers = do + shouldTerminate' <- readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown + guard $ not shouldTerminate' + oldState <- takeTMVar appJobState let missing = num - Map.size (jobWorkers oldState) guard $ missing > 0 @@ -204,6 +205,10 @@ manageJobPool foundation@UniWorX{..} terminateGracefully = do shouldTerminate <- readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown guard shouldTerminate + + oldState <- takeTMVar appJobState + guard $ 0 == Map.size (jobWorkers oldState) + return . callCC $ \terminate -> do $logInfoS "JobPoolManager" "Shutting down" terminate () @@ -214,7 +219,7 @@ stopJobCtl UniWorX{appJobState} = do didStop <- atomically $ do jState <- tryReadTMVar appJobState for jState $ \jSt'@JobState{jobShutdown} -> jSt' <$ tryPutTMVar jobShutdown () - whenIsJust didStop $ \jSt' -> void . forkIO . atomically $ do + whenIsJust didStop $ \jSt' -> void . atomically $ do workers <- maybe [] (Map.keys . jobWorkers) <$> tryTakeTMVar appJobState mapM_ (void . waitCatchSTM) $ [ jobPoolManager jSt' diff --git a/src/Utils/Sql.hs b/src/Utils/Sql.hs index 5c2a504f7..9726b5222 100644 --- a/src/Utils/Sql.hs +++ b/src/Utils/Sql.hs @@ -7,6 +7,7 @@ import ClassyPrelude.Yesod import Database.PostgreSQL.Simple (SqlError(SqlError), sqlErrorHint) import Control.Monad.Catch (MonadMask) +import Database.Persist.Sql import Database.Persist.Sql.Raw.QQ import Control.Retry @@ -14,20 +15,22 @@ import Control.Retry import Control.Lens ((&)) -retryTransaction :: forall m a. (MonadLogger m, MonadMask m, MonadIO m) => m a -> m a -retryTransaction = recovering policy [logRetries suggestRetry logRetry] . const +setSerializable :: forall m a. (MonadLogger m, MonadMask m, MonadIO m) => ReaderT SqlBackend m a -> ReaderT SqlBackend m a +setSerializable act = recovering policy [logRetries suggestRetry logRetry] act' where - policy :: RetryPolicyM m + policy :: RetryPolicyM (ReaderT SqlBackend m) policy = fullJitterBackoff 1e3 & limitRetriesByCumulativeDelay 10e6 - suggestRetry :: SqlError -> m Bool + suggestRetry :: SqlError -> ReaderT SqlBackend m Bool suggestRetry SqlError{sqlErrorHint} = return $ "The transaction might succeed if retried." `isInfixOf` sqlErrorHint logRetry :: Bool -- ^ Will retry -> SqlError -> RetryStatus - -> m () + -> ReaderT SqlBackend m () logRetry shouldRetry err status = $logDebugS "Sql" . pack $ defaultLogMsg shouldRetry err status -setSerializable :: (MonadLogger m, MonadMask m, MonadIO m) => ReaderT SqlBackend m a -> ReaderT SqlBackend m a -setSerializable act = retryTransaction $ [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *> act + act' :: RetryStatus -> ReaderT SqlBackend m a + act' RetryStatus{..} + | rsIterNumber == 0 = [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *> act + | otherwise = transactionUndoWithIsolation Serializable *> act From 5ebcd89e11841fd777f9ab6fbe1c4c46b02313a7 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 25 Sep 2019 18:51:54 +0200 Subject: [PATCH 08/38] fix: restore behaviour of waiting asynchronously for job-management --- src/Jobs.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Jobs.hs b/src/Jobs.hs index 39a1d7bac..d2de34d8d 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -55,6 +55,8 @@ import Data.Time.Zones import Control.Concurrent.STM (retry) import Control.Concurrent.STM.Delay +import UnliftIO.Concurrent (forkIO) + import Jobs.Handler.SendNotification import Jobs.Handler.SendTestEmail @@ -219,7 +221,7 @@ stopJobCtl UniWorX{appJobState} = do didStop <- atomically $ do jState <- tryReadTMVar appJobState for jState $ \jSt'@JobState{jobShutdown} -> jSt' <$ tryPutTMVar jobShutdown () - whenIsJust didStop $ \jSt' -> void . atomically $ do + whenIsJust didStop $ \jSt' -> void . forkIO . atomically $ do workers <- maybe [] (Map.keys . jobWorkers) <$> tryTakeTMVar appJobState mapM_ (void . waitCatchSTM) $ [ jobPoolManager jSt' From fb0a237896f13258cd1da811bca876ba73f881c2 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 25 Sep 2019 19:10:59 +0200 Subject: [PATCH 09/38] chore(release): 7.0.0 --- CHANGELOG.md | 43 +++++++++++++++++++++++++++++++++++++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 46 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index c38052ada..70a4feb39 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,49 @@ 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. +## [7.0.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v6.11.1...v7.0.0) (2019-09-25) + + +### Bug Fixes + +* fix startup on unix-socket ([39f1295](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/39f1295)) +* improve async behaviour ([cc7a528](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/cc7a528)) +* make migration idempotent again ([9778404](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/9778404)) +* restore behaviour of waiting asynchronously for job-management ([5ebcd89](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/5ebcd89)) +* **communication:** make communication form more intuitive ([7a2b972](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/7a2b972)), closes [#387](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/387) +* fix migration ([d2478a3](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d2478a3)) +* fix migration & tests ([e05ea8e](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/e05ea8e)) +* migration ([4383eb1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/4383eb1)) +* syntax ([7afd569](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/7afd569)) +* **migration:** drop more tables in w.a. for inconsistent 21→22 ([d79dca6](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d79dca6)) +* typo ([fb1e42d](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/fb1e42d)) + + +### chore + +* bump versions ([67e3b38](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/67e3b38)) + + +### Features + +* **course:** additional crosslinking ([5eaba78](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/5eaba78)) +* **exam-users:** document part-* family of columns ([fe07a22](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/fe07a22)) +* **exams:** accept/reset computed results ([72342f1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/72342f1)) +* **exams:** automatically compute examResults ([ea5a398](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/ea5a398)) +* **exams:** better display exam-result-information ([0ebda4d](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/0ebda4d)) +* **exams:** csv-import of ExamPartResults ([29f4e28](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/29f4e28)) +* **exams:** implement rounding of exambonus ([e97cd56](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/e97cd56)) +* **exams:** refine exam form ([014a17a](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/014a17a)) + + +### BREAKING CHANGES + +* yesod >=1.6 +* **exams:** examPartName no longer required +* **exams:** Introduces ExamPartNumbers + + + ### [6.11.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v6.11.0...v6.11.1) (2019-09-17) diff --git a/package-lock.json b/package-lock.json index 67c13819f..5854e7166 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "6.11.1", + "version": "7.0.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 14784856d..242dc4284 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "6.11.1", + "version": "7.0.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index f7445cd95..1d3882e41 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 6.11.1 +version: 7.0.0 dependencies: - base >=4.9.1.0 && <5 From c553414b388685e747f94495c85ea5f50b97f52a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 26 Sep 2019 11:00:52 +0200 Subject: [PATCH 10/38] chore: reduce number of workers during testing --- app/DevelMain.hs | 4 ++-- config/test-settings.yml | 2 ++ 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/app/DevelMain.hs b/app/DevelMain.hs index ab065aaa2..b850b33b2 100644 --- a/app/DevelMain.hs +++ b/app/DevelMain.hs @@ -67,7 +67,7 @@ update = do restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do killThread tid withStore doneStore takeMVar - readStore doneStore >>= start + withStore doneStore start -- | Start the server in a separate thread. @@ -77,7 +77,7 @@ update = do (port, site, app) <- getApplicationRepl resourceForkIO $ do finally (liftIO $ runSettings (setPort port defaultSettings) app) - (liftIO $ shutdownApp site >> putMVar done ()) + (liftIO $ shutdownApp site `finally` putMVar done ()) -- | kill the server shutdown :: IO () diff --git a/config/test-settings.yml b/config/test-settings.yml index 23f59aed5..5fb61bedf 100644 --- a/config/test-settings.yml +++ b/config/test-settings.yml @@ -8,3 +8,5 @@ log-settings: destination: "test.log" auth-dummy-login: true + +job-workers: 1 From 54e94a667027548056a12139ac96512fc4609911 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 26 Sep 2019 11:01:32 +0200 Subject: [PATCH 11/38] feat(exams): re-introduce ExamBonusManual --- messages/uniworx/de.msg | 2 ++ src/Application.hs | 16 ++++++++-- src/Handler/Exam/Users.hs | 49 +++++++++++++++--------------- src/Handler/Utils/Exam.hs | 10 +++--- src/Handler/Utils/Form.hs | 10 ++++-- src/Model/Types/Exam.hs | 5 ++- templates/widgets/bonusRule.hamlet | 2 ++ 7 files changed, 60 insertions(+), 34 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 41e50c599..bee90fb85 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1348,6 +1348,7 @@ ExamBonus: Bonuspunkte-System ExamBonusRule: Prüfungsbonus aus Übungsbetrieb ExamNoBonus': Kein automatischer Bonus ExamBonusPoints': Umrechnung von Übungspunkten +ExamBonusManual': Manuelle Berechnung ExamBonusAchieved: Bonuspunkte @@ -1417,6 +1418,7 @@ ExamEdited exam@ExamName: #{exam} erfolgreich bearbeitet ExamNoShow: Nicht erschienen ExamVoided: Entwertet +ExamBonusManualParticipants: Von den Kursverwaltern manuell berechnet ExamBonusPoints possible@Points: Maximal #{showFixed True possible} Prüfungspunkte ExamBonusPointsPassed possible@Points: Maximal #{showFixed True possible} Prüfungspunkte, falls die Prüfung auch ohne Bonus bereits bestanden ist diff --git a/src/Application.hs b/src/Application.hs index 1181b9a9f..294e1a206 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -24,7 +24,7 @@ import Language.Haskell.TH.Syntax (qLocation) import Network.Wai (Middleware) import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException, - runSettingsSocket, setHost, + runSettings, runSettingsSocket, setHost, setBeforeMainLoop, setOnException, setPort, getPort) import Data.Streaming.Network (bindPortTCP) @@ -74,7 +74,7 @@ import qualified Database.Memcached.Binary.IO as Memcached import qualified System.Systemd.Daemon as Systemd import System.Environment (lookupEnv) import System.Posix.Process (getProcessID) -import System.Posix.Signals (SignalInfo(..), installHandler, sigTERM) +import System.Posix.Signals (SignalInfo(..), installHandler, sigTERM, sigINT) import qualified System.Posix.Signals as Signals (Handler(..)) import Network.Socket (socketPort, Socket, PortNumber) @@ -82,6 +82,7 @@ import qualified Network.Socket as Socket (close) import Control.Concurrent.STM.Delay import Control.Monad.STM (retry) +import Control.Monad.Trans.Cont (runContT, callCC) import qualified Data.Set as Set @@ -366,8 +367,17 @@ develMain = runResourceT $ do wsettings <- liftIO . getDevSettings $ warpSettings foundation app <- makeApplication foundation + let + awaitTermination :: IO () + awaitTermination + = flip runContT return . forever $ do + lift $ threadDelay 100e3 + whenM (lift $ doesFileExist "yesod-devel/devel-terminate") $ + callCC ($ ()) + + void . liftIO $ installHandler sigINT (Signals.Catch $ return ()) Nothing runAppLoggingT foundation $ handleJobs foundation - liftIO . develMainHelper $ return (wsettings, app) + void . liftIO $ awaitTermination `race` runSettings wsettings app -- | The @main@ function for an executable running this site. appMain :: forall m. MonadUnliftIO m => m () diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index a7f4f71e0..121f430ff 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -160,7 +160,7 @@ resultCourseNote = _dbrOutput . _10 . _Just resultAutomaticExamBonus :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData Points -resultAutomaticExamBonus exam examBonus' = resultUser . _entityKey . folding (\uid -> examResultBonus <$> examBonusRule exam <*> examBonusPossible uid examBonus' <*> examBonusAchieved uid examBonus') +resultAutomaticExamBonus exam examBonus' = resultUser . _entityKey . folding (\uid -> examResultBonus <$> examBonusRule exam <*> pure (examBonusPossible uid examBonus') <*> pure (examBonusAchieved uid examBonus')) resultAutomaticExamResult :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData ExamResultGrade resultAutomaticExamResult exam examBonus' = folding . runReader $ do @@ -396,7 +396,7 @@ postEUsersR tid ssh csh examn = do allBoni :: SheetGradeSummary allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus - doBonus = is _Just examGradingRule || is _Just examBonusRule + doBonus = is _Just examBonusRule showPasses = doBonus && numSheetsPasses allBoni /= 0 showPoints = doBonus && getSum (numSheetsPoints allBoni) /= 0 @@ -494,14 +494,14 @@ postEUsersR tid ssh csh examn = do , pure $ colDegreeShort resultStudyDegree , pure $ colFeaturesSemester resultStudyFeatures , pure $ sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence - , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do - SheetGradeSummary{achievedPasses} <- examBonusAchieved uid bonus - SheetGradeSummary{numSheetsPasses} <- examBonusPossible uid bonus - return $ propCell (getSum achievedPasses) (getSum numSheetsPasses) - , guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do - SheetGradeSummary{achievedPoints} <- examBonusAchieved uid bonus - SheetGradeSummary{sumSheetsPoints} <- examBonusPossible uid bonus - return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints) + , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> + let SheetGradeSummary{achievedPasses} = examBonusAchieved uid bonus + SheetGradeSummary{numSheetsPasses} = examBonusPossible uid bonus + in propCell (getSum achievedPasses) (getSum numSheetsPasses) + , guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) -> + let SheetGradeSummary{achievedPoints} = examBonusAchieved uid bonus + SheetGradeSummary{sumSheetsPoints} = examBonusPossible uid bonus + in propCell (getSum achievedPoints) (getSum sumSheetsPoints) , guardOn doBonus $ sortable (Just "bonus") (i18nCell MsgExamBonusAchieved) . automaticCell $ resultExamBonus . _entityVal . _examBonusBonus . to Right <> resultAutomaticExamBonus' . to Left , pure $ mconcat [ sortable (Just $ fromText [st|part-#{toPathPiece examPartNumber}|]) (i18nCell $ MsgExamPartNumbered examPartNumber) $ maybe mempty i18nCell . preview (resultExamPartResult epId . _Just . _entityVal . _examPartResultResult) @@ -612,10 +612,10 @@ postEUsersR tid ssh csh examn = do <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just) <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester) <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName) - <*> previews (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped) (bool (const Nothing) Just showPoints) - <*> previews (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses) - <*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped) (bool (const Nothing) Just showPoints) - <*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses) + <*> previews (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPoints . _Wrapped) (bool (const Nothing) Just showPoints) + <*> previews (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses) + <*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _sumSheetsPoints . _Wrapped) (bool (const Nothing) Just showPoints) + <*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _numSheetsPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses) <*> previews (resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus') (bool (const Nothing) Just doBonus) <*> (Map.fromList . map (over _1 examPartNumber . over (_2 . _Just) (examPartResultResult . entityVal)) <$> asks (toListOf resultExamParts)) <*> previews (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') resultView @@ -645,7 +645,7 @@ postEUsersR tid ssh csh examn = do when (epNumber `elem` examPartNumbers) $ yield $ ExamUserCsvSetPartResultData uid epNumber (Just epRes) - when (is _Just . join $ csvEUserBonus dbCsvNew) $ + when (doBonus && is _Just (join $ csvEUserBonus dbCsvNew)) $ yield . ExamUserCsvSetBonusData False uid . join $ csvEUserBonus dbCsvNew when (is _Just $ csvEUserExamResult dbCsvNew) $ @@ -684,15 +684,16 @@ postEUsersR tid ssh csh examn = do newResult = fmap resultView <$> examGrade examVal (newBonus <|> oldBonus) =<< newResults oldResult = dbCsvOld ^? (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') . to resultView - case newBonus of - _ | newBonus == oldBonus - -> return () - _ | is _Nothing newBonus - -> return () - Nothing - -> yield $ ExamUserCsvSetBonusData False uid newBonus - Just _ - -> yield $ ExamUserCsvSetBonusData True uid newBonus + when doBonus $ + case newBonus of + _ | newBonus == oldBonus + -> return () + _ | is _Nothing newBonus + -> return () + Nothing + -> yield $ ExamUserCsvSetBonusData False uid newBonus + Just _ + -> yield $ ExamUserCsvSetBonusData True uid newBonus case newResult of _ | csvEUserExamResult dbCsvNew == oldResult diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 9f6bbe364..ec5d7f5d2 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -78,12 +78,12 @@ examBonus (Entity eId Exam{..}) = runConduit $ ) return (examRegistration E.^. ExamRegistrationUser, sheet E.^. SheetType, submission) accum = C.fold ?? Map.empty $ \acc (E.Value uid, E.Value sheetType, fmap entityVal -> sub) -> - Map.unionWith mappend acc . Map.singleton uid . sheetTypeSum sheetType . (>>= submissionRatingPoints) $ assertM submissionRatingDone sub + flip (Map.insertWith mappend uid) acc . sheetTypeSum sheetType $ assertM submissionRatingDone sub >>= submissionRatingPoints in rawData .| accum -examBonusPossible, examBonusAchieved :: UserId -> Map UserId SheetTypeSummary -> Maybe SheetGradeSummary -examBonusPossible uid bonusMap = normalSummary <$> Map.lookup uid bonusMap -examBonusAchieved uid bonusMap = (mappend <$> normalSummary <*> bonusSummary) <$> Map.lookup uid bonusMap +examBonusPossible, examBonusAchieved :: UserId -> Map UserId SheetTypeSummary -> SheetGradeSummary +examBonusPossible uid bonusMap = normalSummary $ Map.findWithDefault mempty uid bonusMap +examBonusAchieved uid bonusMap = mappend <$> normalSummary <*> bonusSummary $ Map.findWithDefault mempty uid bonusMap examResultBonus :: ExamBonusRule @@ -91,6 +91,8 @@ examResultBonus :: ExamBonusRule -> SheetGradeSummary -- ^ `examBonusAchieved` -> Points examResultBonus bonusRule bonusPossible bonusAchieved = case bonusRule of + ExamBonusManual{} + -> 0 ExamBonusPoints{..} -> roundToPoints bonusRound $ toRational bonusMaxPoints * bonusProp where diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 6556d1db7..2f8af499c 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -520,7 +520,8 @@ submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ c ) ] -data ExamBonusRule' = ExamBonusPoints' +data ExamBonusRule' = ExamBonusManual' + | ExamBonusPoints' deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe ExamBonusRule' instance Finite ExamBonusRule' @@ -530,6 +531,7 @@ embedRenderMessage ''UniWorX ''ExamBonusRule' id classifyBonusRule :: ExamBonusRule -> ExamBonusRule' classifyBonusRule = \case + ExamBonusManual{} -> ExamBonusManual' ExamBonusPoints{} -> ExamBonusPoints' examBonusRuleForm :: Maybe ExamBonusRule -> AForm Handler ExamBonusRule @@ -537,7 +539,11 @@ examBonusRuleForm prev = multiActionA actions (fslI MsgExamBonusRule) $ classify where actions :: Map ExamBonusRule' (AForm Handler ExamBonusRule) actions = Map.fromList - [ ( ExamBonusPoints' + [ ( ExamBonusManual' + , ExamBonusManual + <$> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamBonusOnlyPassed) (Just <$> preview _bonusOnlyPassed =<< prev)) + ) + , ( ExamBonusPoints' , ExamBonusPoints <$> apreq (checkBool (> 0) MsgExamBonusMaxPointsNonPositive pointsField) (fslI MsgExamBonusMaxPoints & setTooltip MsgExamBonusMaxPointsTip) (preview _bonusMaxPoints =<< prev) <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamBonusOnlyPassed) (Just <$> preview _bonusOnlyPassed =<< prev)) diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index 53d900584..1a3f3ec0d 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -116,7 +116,10 @@ instance Universe res => Universe (ExamResult' res) where instance Finite res => Finite (ExamResult' res) -data ExamBonusRule = ExamBonusPoints +data ExamBonusRule = ExamBonusManual + { bonusOnlyPassed :: Bool + } + | ExamBonusPoints { bonusMaxPoints :: Points , bonusOnlyPassed :: Bool , bonusRound :: Points diff --git a/templates/widgets/bonusRule.hamlet b/templates/widgets/bonusRule.hamlet index 3a5a2c775..1c59049c0 100644 --- a/templates/widgets/bonusRule.hamlet +++ b/templates/widgets/bonusRule.hamlet @@ -1,5 +1,7 @@ $newline never $case bonusRule + $of ExamBonusManual _ + _{MsgExamBonusManualParticipants} $of ExamBonusPoints ps False _ _{MsgExamBonusPoints ps} $of ExamBonusPoints ps True _ From adc8d466ac0948dcddf601fac439bb4e8d3bf619 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 26 Sep 2019 11:56:33 +0200 Subject: [PATCH 12/38] fix(jobs): cleaner shutdown of job-pool-manager --- src/Application.hs | 4 ++-- src/Jobs.hs | 34 ++++++++++++++++++++++++++-------- src/UnliftIO/Async/Utils.hs | 20 ++++++++++++++++++++ 3 files changed, 48 insertions(+), 10 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index 294e1a206..41ca6fed4 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -380,7 +380,7 @@ develMain = runResourceT $ do void . liftIO $ awaitTermination `race` runSettings wsettings app -- | The @main@ function for an executable running this site. -appMain :: forall m. MonadUnliftIO m => m () +appMain :: forall m. (MonadUnliftIO m, MonadMask m) => m () appMain = runResourceT $ do settings <- getAppSettings @@ -472,7 +472,7 @@ appMain = runResourceT $ do foundationStoreNum :: Word32 foundationStoreNum = 2 -getApplicationRepl :: (MonadResource m, MonadUnliftIO m) => m (Int, UniWorX, Application) +getApplicationRepl :: (MonadResource m, MonadUnliftIO m, MonadMask m) => m (Int, UniWorX, Application) getApplicationRepl = do settings <- getAppDevSettings foundation <- makeFoundation settings diff --git a/src/Jobs.hs b/src/Jobs.hs index d2de34d8d..587aa9ac3 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -86,6 +86,7 @@ instance Exception JobQueueException handleJobs :: ( MonadResource m , MonadLogger m , MonadUnliftIO m + , MonadMask m ) => UniWorX -> m () -- | Spawn a set of workers that read control commands from `appJobCtl` and address them as they come in @@ -97,7 +98,7 @@ handleJobs foundation@UniWorX{..} | otherwise = do UnliftIO{..} <- askUnliftIO - jobPoolManager <- allocateLinkedAsync . unliftIO $ manageJobPool foundation + jobPoolManager <- allocateLinkedAsyncWithUnmask $ \unmask -> unliftIO $ manageJobPool foundation unmask jobCron <- allocateLinkedAsync . unliftIO $ manageCrontab foundation @@ -129,15 +130,32 @@ manageJobPool :: forall m. ( MonadResource m , MonadLogger m , MonadUnliftIO m + , MonadMask m ) - => UniWorX -> m () -manageJobPool foundation@UniWorX{..} - = flip runContT return . forever . join . atomically $ asum - [ spawnMissingWorkers - , reapDeadWorkers - , terminateGracefully - ] + => UniWorX -> (forall a. IO a -> IO a) -> m () +manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ + flip runContT return . forever . join . atomically $ asum + [ spawnMissingWorkers + , reapDeadWorkers + , terminateGracefully + ] where + shutdownOnException :: m a -> m a + shutdownOnException act = do + UnliftIO{..} <- askUnliftIO + + actAsync <- allocateLinkedAsyncMasked $ unliftIO act + + let handleExc e = do + atomically $ do + jState <- tryReadTMVar appJobState + for_ jState $ \JobState{jobShutdown} -> tryPutTMVar jobShutdown () + + void $ wait actAsync + throwM e + + unmask (wait actAsync) `catchAll` handleExc + num :: Int num = fromIntegral $ foundation ^. _appJobWorkers diff --git a/src/UnliftIO/Async/Utils.hs b/src/UnliftIO/Async/Utils.hs index 862d057e4..fb1dbc978 100644 --- a/src/UnliftIO/Async/Utils.hs +++ b/src/UnliftIO/Async/Utils.hs @@ -1,5 +1,7 @@ module UnliftIO.Async.Utils ( allocateAsync, allocateLinkedAsync + , allocateAsyncWithUnmask, allocateLinkedAsyncWithUnmask + , allocateAsyncMasked, allocateLinkedAsyncMasked ) where import ClassyPrelude hiding (cancel, async, link) @@ -17,3 +19,21 @@ allocateAsync = fmap (view _2) . flip allocate cancel . liftIO . async allocateLinkedAsync :: forall m a. (MonadUnliftIO m, MonadResource m) => IO a -> m (Async a) allocateLinkedAsync = uncurry (<$) . (id &&& link) <=< allocateAsync + + +allocateAsyncWithUnmask :: forall m a. + MonadResource m + => ((forall b. IO b -> IO b) -> IO a) -> m (Async a) +allocateAsyncWithUnmask act = fmap (view _2) . flip allocate cancel . liftIO $ asyncWithUnmask act + +allocateLinkedAsyncWithUnmask :: forall m a. (MonadUnliftIO m, MonadResource m) => ((forall b. IO b -> IO b) -> IO a) -> m (Async a) +allocateLinkedAsyncWithUnmask act = uncurry (<$) . (id &&& link) =<< allocateAsyncWithUnmask act + + +allocateAsyncMasked :: forall m a. + MonadResource m + => IO a -> m (Async a) +allocateAsyncMasked act = fmap (view _2) . flip allocate cancel . liftIO $ asyncWithUnmask (const act) + +allocateLinkedAsyncMasked :: forall m a. (MonadUnliftIO m, MonadResource m) => IO a -> m (Async a) +allocateLinkedAsyncMasked = uncurry (<$) . (id &&& link) <=< allocateAsyncMasked From 72bb2d562a766938783cb67e98cf390cd459ce21 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 26 Sep 2019 11:58:29 +0200 Subject: [PATCH 13/38] chore: bump changelog --- templates/i18n/changelog/de.hamlet | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/templates/i18n/changelog/de.hamlet b/templates/i18n/changelog/de.hamlet index 4502079c5..004420443 100644 --- a/templates/i18n/changelog/de.hamlet +++ b/templates/i18n/changelog/de.hamlet @@ -1,5 +1,14 @@ $newline never
+
+ ^{formatGregorianW 2019 09 25} +
+
    +
  • Automatische Berechnung von Prufüngsboni +
  • Automatische Berechnung von Prüfungsleistungen +
  • Bugfix: Uhrzeiten werden beim Laden eines Formulars nichtmehr zurückgesetzt +
  • Bugfix: Studierende tauchen in der Prüfungsleistungen-Tabelle nicht mehr mehrfach auf +
    ^{formatGregorianW 2019 09 16}
    From a94eb5394e9a81738e99bdfd682e8c67bbc0a4e9 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 26 Sep 2019 12:02:16 +0200 Subject: [PATCH 14/38] chore(release): 7.1.0 --- CHANGELOG.md | 15 +++++++++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 18 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 70a4feb39..f59e4094c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,21 @@ 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. +## [7.1.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.0.0...v7.1.0) (2019-09-26) + + +### Bug Fixes + +* **datepicker:** select time from preselected date on edit ([d3375bb](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d3375bb)) +* **jobs:** cleaner shutdown of job-pool-manager ([adc8d46](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/adc8d46)) + + +### Features + +* **exams:** re-introduce ExamBonusManual ([54e94a6](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/54e94a6)) + + + ## [7.0.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v6.11.1...v7.0.0) (2019-09-25) diff --git a/package-lock.json b/package-lock.json index 5854e7166..f965858f9 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "7.0.0", + "version": "7.1.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 242dc4284..4381e9213 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "7.0.0", + "version": "7.1.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 1d3882e41..c17e7a057 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 7.0.0 +version: 7.1.0 dependencies: - base >=4.9.1.0 && <5 From d13ace4eddb581167544de5e5f788ab6d5836041 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 26 Sep 2019 13:37:38 +0200 Subject: [PATCH 15/38] fix: fix build --- src/Jobs.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Jobs.hs b/src/Jobs.hs index 587aa9ac3..a78b8dc39 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -154,7 +154,7 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ void $ wait actAsync throwM e - unmask (wait actAsync) `catchAll` handleExc + liftIO (unmask $ wait actAsync) `catchAll` handleExc num :: Int num = fromIntegral $ foundation ^. _appJobWorkers From 0e13e7773f9221c4627e624d33ea9221dafb515b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 26 Sep 2019 13:43:49 +0200 Subject: [PATCH 16/38] chore(release): 7.1.1 --- CHANGELOG.md | 9 +++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 12 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index f59e4094c..dcc26796b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,15 @@ 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. +### [7.1.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.1.0...v7.1.1) (2019-09-26) + + +### Bug Fixes + +* fix build ([d13ace4](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d13ace4)) + + + ## [7.1.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.0.0...v7.1.0) (2019-09-26) diff --git a/package-lock.json b/package-lock.json index f965858f9..8f4715665 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "7.1.0", + "version": "7.1.1", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 4381e9213..615188a44 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "7.1.0", + "version": "7.1.1", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index c17e7a057..924513245 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 7.1.0 +version: 7.1.1 dependencies: - base >=4.9.1.0 && <5 From 2bc68946e379e7d29a85148017ca9fd14b01ab18 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 26 Sep 2019 14:37:55 +0200 Subject: [PATCH 17/38] fix(exams): include bonus points in sum for exam participants --- src/Handler/Exam/Show.hs | 8 +++++++- src/Utils/Form.hs | 2 +- templates/exam-show.hamlet | 2 +- 3 files changed, 9 insertions(+), 3 deletions(-) diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index 27c55a9b4..9ee2da005 100644 --- a/src/Handler/Exam/Show.hs +++ b/src/Handler/Exam/Show.hs @@ -72,11 +72,17 @@ getEShowR tid ssh csh examn = do examClosedShown = lecturerInfoShown sumMaxPoints = sum [ fromRational examPartWeight * mPoints | Entity _ ExamPart{..} <- examParts, let Just mPoints = examPartMaxPoints ] - sumPoints = getSum <$> foldMap (fmap Sum . examPartResultResult . entityVal) results noBonus = fromMaybe False $ do guardM $ bonusOnlyPassed <$> examBonusRule return . fromMaybe True $ result ^? _Just . _entityVal . _examResultResult . _examResult . passingGrade . _Wrapped . to not + + sumPoints = fmap getSum . mconcat $ catMaybes + [ Just $ foldMap (fmap Sum . examPartResultResult . entityVal) results + , guard (not noBonus) *> fmap (pure . Sum . examBonusBonus . entityVal) bonus + ] + + hasRegistration = any snd occurrences let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 1a7d32b74..31bc5ad08 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -328,7 +328,7 @@ combinedButtonField :: forall a m. ) => [a] -> FieldSettings (HandlerSite m) -> AForm m [Maybe a] combinedButtonField bs FieldSettings{..} = formToAForm $ do mr <- getMessageRender - fvId <- maybe newFormIdent return fsId + fvId <- maybe newIdent return fsId name <- maybe newFormIdent return fsName (ress, fvs) <- fmap unzip . for bs $ \b -> mopt (buttonField b) ("" { fsId = Just $ fvId <> "__" <> toPathPiece b , fsName = Just $ name <> "__" <> toPathPiece b diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index b05d2c2b6..44ff63632 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -114,7 +114,7 @@ $if not (null occurrences) _{MsgExamRoomDescription} $forall (Entity _occId ExamOccurrence{examOccurrenceName, examOccurrenceRoom, examOccurrenceStart, examOccurrenceEnd, examOccurrenceDescription}, registered) <- occurrences - + $if occurrenceNamesShown #{examOccurrenceName} $if occurrenceAssignmentsShown From 1d737e40d2ac1f3159d6b27452a8ae657ee0499f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 26 Sep 2019 15:09:19 +0200 Subject: [PATCH 18/38] chore(release): 7.1.2 --- CHANGELOG.md | 9 +++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 12 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index dcc26796b..358407fc7 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,15 @@ 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. +### [7.1.2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.1.1...v7.1.2) (2019-09-26) + + +### Bug Fixes + +* **exams:** include bonus points in sum for exam participants ([2bc6894](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/2bc6894)) + + + ### [7.1.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.1.0...v7.1.1) (2019-09-26) diff --git a/package-lock.json b/package-lock.json index 8f4715665..688e709db 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "7.1.1", + "version": "7.1.2", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 615188a44..49dde0422 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "7.1.1", + "version": "7.1.2", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 924513245..d0d6be148 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 7.1.1 +version: 7.1.2 dependencies: - base >=4.9.1.0 && <5 From 1cfd107aaf223d255c990951fb90555898d5815b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 26 Sep 2019 15:09:32 +0200 Subject: [PATCH 19/38] chore: introduce FORCE_RELEASE --- is-clean.sh | 2 ++ test.sh | 2 ++ 2 files changed, 4 insertions(+) diff --git a/is-clean.sh b/is-clean.sh index b63b54f46..4bcf4bd7d 100755 --- a/is-clean.sh +++ b/is-clean.sh @@ -1,5 +1,7 @@ #!/usr/bin/env bash +[[ -n "${FORCE_RELEASE}" ]] && exit 0 + set -e if [ -n "$(git status --porcelain)" ]; then diff --git a/test.sh b/test.sh index 4d2eca141..e0ef0b657 100755 --- a/test.sh +++ b/test.sh @@ -1,5 +1,7 @@ #!/usr/bin/env bash +[[ -n "${FORCE_RELEASE}" ]] && exit 0 + set -e [ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || : From 16abcd2265136b63e28dbde252f44c94417d0aff Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 26 Sep 2019 16:50:30 +0200 Subject: [PATCH 20/38] fix: don't treat ExamBonusManual as override --- src/Handler/Exam/Users.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 121f430ff..966853113 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -690,6 +690,8 @@ postEUsersR tid ssh csh examn = do -> return () _ | is _Nothing newBonus -> return () + _ | Just ExamBonusManual{} <- examBonusRule + -> yield $ ExamUserCsvSetBonusData False uid newBonus Nothing -> yield $ ExamUserCsvSetBonusData False uid newBonus Just _ From 620950df83e3dc4d1f0050af4bb207d25883800e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 27 Sep 2019 11:46:25 +0200 Subject: [PATCH 21/38] feat(course-applications): automatic acceptance of direct applicants --- messages/uniworx/de.msg | 16 +- src/Handler/Course/Application/List.hs | 149 ++++++++++++++++-- src/Handler/Course/ParticipantInvite.hs | 114 ++++++++------ src/Handler/Utils/Submission.hs | 4 - src/Import/NoModel.hs | 4 + src/Model/Types/Exam.hs | 10 ++ src/Utils.hs | 16 ++ src/Yesod/Core/Types/Instances.hs | 4 + templates/course/applications-list.hamlet | 44 +++--- .../courseInvitationAlreadyRegistered.hamlet | 2 +- ...rseInvitationRegisteredWithoutField.hamlet | 2 +- 11 files changed, 275 insertions(+), 90 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index bee90fb85..f6bb5cfa4 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -173,6 +173,7 @@ CourseApplicationTemplateApplication: Bewerbungsvorlage(n) CourseApplicationTemplateRegistration: Anmeldungsvorlage(n) CourseApplicationTemplateArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-bewerbungsvorlagen CourseApplication: Bewerbung +CourseApplicationIsParticipant: Kursteilnehmer CourseApplicationExists: Sie haben sich bereits für diesen Kurs beworben CourseApplicationInvalidAction: Angegeben Aktion kann nicht durchgeführt werden @@ -1529,7 +1530,7 @@ CsvColumnApplicationsSemester: Fachsemester des Bewerbes im assoziierten Studien CsvColumnApplicationsText: Text-Bewerbung CsvColumnApplicationsHasFiles: Hat der Bewerber Dateien zu seiner Bewerbung eingereicht (siehe ZIP-Archiv aller Bewerbungsdateien)? CsvColumnApplicationsVeto: Bewerber mit Veto werden garantiert nicht dem Kurs zugeteilt; "veto" oder leer -CsvColumnApplicationsRating: Bewertung der Bewerbung; "1.0", "1.3", "1.7", ..., "4.0", "5.0" +CsvColumnApplicationsRating: Bewertung der Bewerbung; "1.0", "1.3", "1.7", ..., "4.0", "5.0" (Leer wird behandelt wie eine Note zwischen 2.3 und 2.7) CsvColumnApplicationsComment: Kommentar zur Bewerbung; je nach Kurs-Einstellungen entweder nur als Notiz für die Kursverwalter oder Feedback für den Bewerber Action: Aktion @@ -1785,4 +1786,15 @@ ExamCloseTip: Wenn eine Klausur abgeschlossen wird, werden Prüfungsämter, die ExamCloseReminder: Bitte schließen Sie die Klausur frühstmöglich, sobald die Prüfungsleistungen sich voraussichtlich nicht mehr ändern werden. Z.B. direkt nach der Klausureinsicht. ExamDidClose: Klausur erfolgreich abgeschlossen -ExamClosedSince time@Text: Klausur abgeschlossen seit #{time} \ No newline at end of file +ExamClosedSince time@Text: Klausur abgeschlossen seit #{time} + +BtnAcceptApplications: Bewerbungen akzeptieren +BtnAcceptApplicationsTip: Mit dem untigen Knopf können Sie den Kurs (höchstens bis zur angegeben Maximalkapazität, falls eingestellt) mit Bewerbern auffüllen. Die Bewertungen der Bewerbungen werden dabei berücksichtigt (Unbewertet wird behandelt wie eine Note zwischen 2.3 und 2.7). Bewerber mit Veto oder 5.0 werden nicht angemeldet. +AcceptApplicationsMode: Bewerbungen akzeptieren +AcceptApplicationsModeTip: Sollen akzeptierte Bewerber direkt als Teilnehmer im Kurs eingetragen werden oder sollen Einladungen per E-Mail verschickt werden? +AcceptApplicationsDirect: Direkt anmelden +AcceptApplicationsInvite: Einladungen verschicken +AcceptApplicationsSecondary: Gleichstände auflösen +AcceptApplicationsSecondaryTip: Wenn es im Laufe des Verfahrens mehrere Bewerber mit der selben Bewertung für den selben Platz gibt, wie soll der Gleichstand aufgelöst werden? +AcceptApplicationsSecondaryRandom: Zufällig +AcceptApplicationsSecondaryTime: Nach Zeitpunkt der Bewerbung \ No newline at end of file diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index 312ff9d02..f3f8de21b 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -25,6 +25,10 @@ import qualified Data.Map as Map import qualified Data.Conduit.List as C +import Handler.Course.ParticipantInvite + +import Jobs.Queue + type CourseApplicationsTableExpr = ( E.SqlExpr (Entity CourseApplication) `E.InnerJoin` E.SqlExpr (Entity User) @@ -34,41 +38,49 @@ type CourseApplicationsTableExpr = ( E.SqlExpr (Entity CourseApplic `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) ) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseParticipant)) type CourseApplicationsTableData = DBRow ( Entity CourseApplication , Entity User - , E.Value Bool -- hasFiles + , Bool -- hasFiles , Maybe (Entity Allocation) , Maybe (Entity StudyFeatures) , Maybe (Entity StudyTerms) , Maybe (Entity StudyDegree) + , Bool -- isParticipant ) courseApplicationsIdent :: Text courseApplicationsIdent = "applications" queryCourseApplication :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity CourseApplication)) -queryCourseApplication = to $ $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) +queryCourseApplication = to $ $(sqlIJproj 2 1) . $(sqlLOJproj 4 1) queryUser :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity User)) -queryUser = to $ $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) +queryUser = to $ $(sqlIJproj 2 2) . $(sqlLOJproj 4 1) queryHasFiles :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool)) -queryHasFiles = to $ hasFiles . $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) +queryHasFiles = to $ hasFiles . $(sqlIJproj 2 1) . $(sqlLOJproj 4 1) where hasFiles appl = E.exists . E.from $ \courseApplicationFile -> E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. appl E.^. CourseApplicationId queryAllocation :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity Allocation))) -queryAllocation = to $(sqlLOJproj 3 2) +queryAllocation = to $(sqlLOJproj 4 2) queryStudyFeatures :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyFeatures))) -queryStudyFeatures = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 3 3) +queryStudyFeatures = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 4 3) queryStudyTerms :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyTerms))) -queryStudyTerms = to $ $(sqlIJproj 3 2) . $(sqlLOJproj 3 3) +queryStudyTerms = to $ $(sqlIJproj 3 2) . $(sqlLOJproj 4 3) queryStudyDegree :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyDegree))) -queryStudyDegree = to $ $(sqlIJproj 3 3) . $(sqlLOJproj 3 3) +queryStudyDegree = to $ $(sqlIJproj 3 3) . $(sqlLOJproj 4 3) + +queryCourseParticipant :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity CourseParticipant))) +queryCourseParticipant = to $(sqlLOJproj 4 4) + +queryIsParticipant :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool)) +queryIsParticipant = to $ E.not_ . E.isNothing . (E.?. CourseParticipantId) . $(sqlLOJproj 4 4) resultCourseApplication :: Lens' CourseApplicationsTableData (Entity CourseApplication) resultCourseApplication = _dbrOutput . _1 @@ -77,7 +89,7 @@ resultUser :: Lens' CourseApplicationsTableData (Entity User) resultUser = _dbrOutput . _2 resultHasFiles :: Lens' CourseApplicationsTableData Bool -resultHasFiles = _dbrOutput . _3 . _Value +resultHasFiles = _dbrOutput . _3 resultAllocation :: Traversal' CourseApplicationsTableData (Entity Allocation) resultAllocation = _dbrOutput . _4 . _Just @@ -91,6 +103,9 @@ resultStudyTerms = _dbrOutput . _6 . _Just resultStudyDegree :: Traversal' CourseApplicationsTableData (Entity StudyDegree) resultStudyDegree = _dbrOutput . _7 . _Just +resultIsParticipant :: Lens' CourseApplicationsTableData Bool +resultIsParticipant = _dbrOutput . _8 + newtype CourseApplicationsTableVeto = CourseApplicationsTableVeto Bool deriving (Eq, Ord, Read, Show, Generic, Typeable) @@ -205,12 +220,44 @@ data CourseApplicationsTableCsvException instance Exception CourseApplicationsTableCsvException embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvException id + +data ButtonAcceptApplications = BtnAcceptApplications + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe ButtonAcceptApplications +instance Finite ButtonAcceptApplications + +nullaryPathPiece ''ButtonAcceptApplications $ camelToPathPiece' 1 + +embedRenderMessage ''UniWorX ''ButtonAcceptApplications id +instance Button UniWorX ButtonAcceptApplications where + btnClasses BtnAcceptApplications = [BCIsButton] + +data AcceptApplicationsMode = AcceptApplicationsInvite + | AcceptApplicationsDirect + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe AcceptApplicationsMode +instance Finite AcceptApplicationsMode + +nullaryPathPiece ''AcceptApplicationsMode $ camelToPathPiece' 2 + +embedRenderMessage ''UniWorX ''AcceptApplicationsMode id + +data AcceptApplicationsSecondary = AcceptApplicationsSecondaryRandom + | AcceptApplicationsSecondaryTime + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe AcceptApplicationsSecondary +instance Finite AcceptApplicationsSecondary + +nullaryPathPiece ''AcceptApplicationsSecondary $ camelToPathPiece' 3 + +embedRenderMessage ''UniWorX ''AcceptApplicationsSecondary id + getCApplicationsR, postCApplicationsR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCApplicationsR = postCApplicationsR postCApplicationsR tid ssh csh = do - (table, allocationsBounds) <- runDB $ do + (table, allocationsBounds, mayAccept) <- runDB $ do Entity cid Course{..} <- getBy404 $ TermSchoolCourseShort tid ssh csh csvName <- getMessageRender <*> pure (MsgCourseApplicationsTableCsvName tid ssh csh) @@ -237,31 +284,43 @@ postCApplicationsR tid ssh csh = do studyFeatures <- view queryStudyFeatures studyTerms <- view queryStudyTerms studyDegree <- view queryStudyDegree + courseParticipant <- view queryCourseParticipant lift $ do + E.on $ E.just (user E.^. UserId) E.==. courseParticipant E.?. CourseParticipantUser + E.&&. courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val cid) E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree E.on $ studyTerms E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField E.on $ studyFeatures E.?. StudyFeaturesId E.==. courseApplication E.^. CourseApplicationField E.on $ courseApplication E.^. CourseApplicationAllocation E.==. allocation E.?. AllocationId E.on $ user E.^. UserId E.==. courseApplication E.^. CourseApplicationUser - E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid + E.&&. courseApplication E.^. CourseApplicationCourse E.==. E.val cid - return (courseApplication, user, hasFiles, allocation, studyFeatures, studyTerms, studyDegree) + return ( courseApplication + , user + , hasFiles + , allocation + , studyFeatures + , studyTerms + , studyDegree + , E.not_ . E.isNothing $ courseParticipant E.?. CourseParticipantId + ) dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) CourseApplicationsTableData dbtProj = runReaderT $ do - appId <- view $ resultCourseApplication . _entityKey + appId <- view $ _dbrOutput . _1 . _entityKey cID <- encrypt appId guardM . hasReadAccessTo $ CApplicationR tid ssh csh cID CAEditR - view id + asks $ over (_dbrOutput . _3) E.unValue . over (_dbrOutput . _8) E.unValue dbtRowKey = view $ queryCourseApplication . to (E.^. CourseApplicationId) dbtColonnade :: Colonnade Sortable _ _ dbtColonnade = mconcat - [ emptyOpticColonnade (resultAllocation . _entityVal) $ \l -> anchorColonnade (views l allocationLink) $ colAllocationShorthand (l . _allocationShorthand) + [ sortable (Just "participant") (i18nCell MsgCourseApplicationIsParticipant) $ bool mempty (cell $ toWidget iconOK) . view resultIsParticipant + , emptyOpticColonnade (resultAllocation . _entityVal) $ \l -> anchorColonnade (views l allocationLink) $ colAllocationShorthand (l . _allocationShorthand) , anchorColonnadeM (views (resultCourseApplication . _entityKey) applicationLink) $ colApplicationId (resultCourseApplication . _entityKey) , anchorColonnadeM (views (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname) , colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer) @@ -276,7 +335,8 @@ postCApplicationsR tid ssh csh = do ] dbtSorting = mconcat - [ sortAllocationShorthand $ queryAllocation . to (E.?. AllocationShorthand) + [ singletonMap "participant" . SortColumn $ view queryIsParticipant + , sortAllocationShorthand $ queryAllocation . to (E.?. AllocationShorthand) , sortUserName' $ $(multifocusG 2) (queryUser . to (E.^. UserDisplayName)) (queryUser . to (E.^. UserSurname)) , sortUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer) , sortStudyTerms queryStudyTerms @@ -566,12 +626,67 @@ postCApplicationsR tid ssh csh = do || numFirstChoice' /= numFirstChoice ] - (, allocationsBounds) <$> dbTableWidget' psValidator DBTable{..} + mayAccept <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR + + (, allocationsBounds, mayAccept) <$> dbTableWidget' psValidator DBTable{..} now <- liftIO getCurrentTime let title = prependCourseTitle tid ssh csh MsgCourseApplicationsListTitle registrationOpen = maybe True (now <) + + ((acceptRes, acceptWgt'), acceptEnc) <- runFormPost . identifyForm BtnAcceptApplications . renderAForm FormStandard $ + (,) <$> apopt (selectField optionsFinite) (fslI MsgAcceptApplicationsMode & setTooltip MsgAcceptApplicationsModeTip) (Just AcceptApplicationsInvite) + <*> apopt (selectField optionsFinite) (fslI MsgAcceptApplicationsSecondary & setTooltip MsgAcceptApplicationsSecondaryTip) (Just AcceptApplicationsSecondaryTime) + + let acceptWgt = wrapForm' BtnAcceptApplications acceptWgt' def + { formSubmit = FormSubmit + , formAction = Just . SomeRoute $ CourseR tid ssh csh CApplicationsR + , formEncoding = acceptEnc + } + + when mayAccept $ + formResult acceptRes $ \(invMode, appsSecOrder) -> do + runDBJobs $ do + Entity cid Course{..} <- getBy404 $ TermSchoolCourseShort tid ssh csh + participants <- count [ CourseParticipantCourse ==. cid ] + let openCapacity = subtract participants <$> courseCapacity + + applications <- E.select . E.from $ \(user `E.InnerJoin` application) -> do + E.on $ user E.^. UserId E.==. application E.^. CourseApplicationUser + + E.where_ $ application E.^. CourseApplicationCourse E.==. E.val cid + E.&&. E.isNothing (application E.^. CourseApplicationAllocation) + E.&&. E.not_ (application E.^. CourseApplicationRatingVeto) + E.&&. E.maybe E.true (`E.in_` E.valList (filter (view $ passingGrade . _Wrapped) universeF)) (application E.^. CourseApplicationRatingPoints ) + + E.where_ . E.not_ . E.exists . E.from $ \participant -> + E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid + E.&&. participant E.^. CourseParticipantUser E.==. user E.^. UserId + + return (user, application) + + let + ratingL = _2 . _entityVal . _courseApplicationRatingPoints . to (Down . ExamGradeDefCenter) + cmp = case appsSecOrder of + AcceptApplicationsSecondaryTime + -> comparing . view $ $(multifocusG 2) ratingL (_2 . _entityVal . _courseApplicationTime) + AcceptApplicationsSecondaryRandom + -> comparing $ view ratingL + sortedApplications <- unstableSortBy cmp applications + + let applicants = sortedApplications + & nubOn (view $ _1 . _entityKey) + & maybe id take openCapacity + & setOf (case invMode of + AcceptApplicationsDirect -> folded . _1 . _entityKey . to Right + AcceptApplicationsInvite -> folded . _1 . _entityVal . _userEmail . to Left + ) + + mapM_ addMessage' <=< execWriterT $ registerUsers cid applicants + redirect $ CourseR tid ssh csh CUsersR + + siteLayoutMsg title $ do setTitleI title $(widgetFile "course/applications-list") diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index e2962ac0b..9459346a3 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -4,6 +4,9 @@ module Handler.Course.ParticipantInvite ( InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..) , getCInviteR, postCInviteR , getCAddUserR, postCAddUserR + , AddParticipantsResult(..) + , addParticipantsResultMessages + , registerUsers, registerUser ) where import Import @@ -96,16 +99,16 @@ participantInvitationConfig = InvitationConfig{..} return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName) invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR -data AddRecipientsResult = AddRecipientsResult +data AddParticipantsResult = AddParticipantsResult { aurAlreadyRegistered , aurNoUniquePrimaryField - , aurSuccess :: [UserEmail] + , aurSuccess :: Set UserId } deriving (Read, Show, Generic, Typeable) -instance Semigroup AddRecipientsResult where +instance Semigroup AddParticipantsResult where (<>) = mappenddefault -instance Monoid AddRecipientsResult where +instance Monoid AddParticipantsResult where mempty = memptydefault mappend = (<>) @@ -118,7 +121,9 @@ postCAddUserR tid ssh csh = do wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing) (fslI MsgCourseParticipantInviteField & setTooltip MsgMultiEmailFieldTip) Nothing - formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $ processUsers cid + formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $ + hoist runDBJobs . registerUsers cid + let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading @@ -128,57 +133,74 @@ postCAddUserR tid ssh csh = do { formEncoding , formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR } - where - processUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] Handler () - processUsers cid users = do - let (emails,uids) = partitionEithers $ Set.toList users - AddRecipientsResult{..} <- lift . runDBJobs $ do - -- send Invitation eMails to unkown users - sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant)) | mail <- emails] - -- register known users - execWriterT $ mapM (registerUser cid) uids - unless (null emails) $ - tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails +registerUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] (YesodJobDB UniWorX) () +registerUsers cid users = do + let (emails,uids) = partitionEithers $ Set.toList users - unless (null aurAlreadyRegistered) $ do - let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|] - modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered") - tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent) + -- send Invitation eMails to unkown users + lift $ sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant)) | mail <- emails] + -- register known users + tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT $ mapM_ (registerUser cid) uids - unless (null aurNoUniquePrimaryField) $ do - let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisteredWithoutField (length aurNoUniquePrimaryField)}|] - modalContent = $(widgetFile "messages/courseInvitationRegisteredWithoutField") - tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent) + unless (null emails) $ + tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails - unless (null aurSuccess) $ - tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurSuccess - registerUser :: CourseId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) () - registerUser cid uid = exceptT tell tell $ do - User{..} <- lift . lift $ getJust uid +addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) + => AddParticipantsResult + -> ReaderT (YesodPersistBackend UniWorX) m [Message] +addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do + (aurAlreadyRegistered', aurNoUniquePrimaryField') <- + (,) <$> fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurAlreadyRegistered) + <*> fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurNoUniquePrimaryField) - whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $ - throwError $ mempty { aurAlreadyRegistered = pure userEmail } + unless (null aurAlreadyRegistered) $ do + let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|] + modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered") + tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent) - features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] [] + unless (null aurNoUniquePrimaryField) $ do + let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisteredWithoutField (length aurNoUniquePrimaryField)}|] + modalContent = $(widgetFile "messages/courseInvitationRegisteredWithoutField") + tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent) - let courseParticipantField - | [f] <- features = Just f - | otherwise = Nothing + unless (null aurSuccess) $ + tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurSuccess - courseParticipantRegistration <- liftIO getCurrentTime - void . lift . lift . insert $ CourseParticipant - { courseParticipantCourse = cid - , courseParticipantUser = uid - , courseParticipantAllocated = False - , .. - } - lift . lift . audit $ TransactionCourseParticipantEdit cid uid - return $ case courseParticipantField of - Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail } - Just _ -> mempty { aurSuccess = pure userEmail } +registerUser :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) + => CourseId + -> UserId + -> WriterT AddParticipantsResult (ReaderT (YesodPersistBackend UniWorX) m) () +registerUser cid uid = exceptT tell tell $ do + whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $ + throwError $ mempty { aurAlreadyRegistered = Set.singleton uid } + + features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] [] + applications <- lift . lift $ selectList [ CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] [] + + let courseParticipantField + | [f] <- features + = Just f + | [f'] <- nub $ mapMaybe (courseApplicationField . entityVal) applications + , f' `elem` features + = Just f' + | otherwise + = Nothing + + courseParticipantRegistration <- liftIO getCurrentTime + void . lift . lift . insert $ CourseParticipant + { courseParticipantCourse = cid + , courseParticipantUser = uid + , courseParticipantAllocated = False + , .. + } + lift . lift . audit $ TransactionCourseParticipantEdit cid uid + + return $ case courseParticipantField of + Nothing -> mempty { aurNoUniquePrimaryField = Set.singleton uid } + Just _ -> mempty { aurSuccess = Set.singleton uid } getCInviteR, postCInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 383e7fe4e..4df32cd24 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -20,7 +20,6 @@ import Control.Monad.State.Class as State import Control.Monad.Writer (MonadWriter(..), execWriterT, execWriter) import Control.Monad.RWS.Lazy (MonadRWS, RWST, execRWST) import qualified Control.Monad.Random as Rand -import qualified System.Random.Shuffle as Rand (shuffleM) import Data.Maybe () @@ -248,9 +247,6 @@ planSubmissions sid restriction = do maximumsBy :: (Ord a, Ord b) => (a -> b) -> Set a -> Set a maximumsBy f xs = flip Set.filter xs $ \x -> maybe True (((==) `on` f) x . maximumBy (comparing f)) $ fromNullable xs - unstableSortBy :: MonadRandom m => (a -> a -> Ordering) -> [a] -> m [a] - unstableSortBy cmp = fmap concat . mapM Rand.shuffleM . groupBy (\a b -> cmp a b == EQ) . sortBy cmp - submissionFileSource :: SubmissionId -> ConduitT () (Entity File) (YesodDB UniWorX) () submissionFileSource = E.selectSource . fmap snd . E.from . submissionFileQuery diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index bbc0f02d9..ec4e44c34 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -88,6 +88,10 @@ import Control.Monad.Trans.State as Import ( state, State, runState, mapState, withState , StateT(..), mapStateT, withStateT ) +import Control.Monad.Trans.Writer.Lazy as Import + ( writer, Writer, runWriter, mapWriter, execWriter + , WriterT(..), mapWriterT, execWriterT + ) import Control.Monad.Base as Import import Control.Monad.Catch as Import hiding (Handler(..)) import Control.Monad.Trans.Control as Import hiding (embed) diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index 1a3f3ec0d..d7a1ae6e3 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -13,6 +13,7 @@ module Model.Types.Exam , ExamOccurrenceRule(..) , ExamGrade(..) , numberGrade + , ExamGradeDefCenter(..) , ExamGradingRule(..) , ExamPassed(..) , passingGrade @@ -218,6 +219,15 @@ instance PersistFieldSql ExamGrade where sqlType _ = SqlNumeric 2 1 +newtype ExamGradeDefCenter = ExamGradeDefCenter { examGradeDefCenter :: Maybe ExamGrade } + deriving (Eq, Read, Show, Generic, Typeable) + +instance Ord ExamGradeDefCenter where + ExamGradeDefCenter Nothing <= ExamGradeDefCenter (Just g) = Grade23 <= g + ExamGradeDefCenter (Just g) <= ExamGradeDefCenter Nothing = g <= Grade27 + ExamGradeDefCenter g <= ExamGradeDefCenter g' = g <= g' + + data ExamGradingRule = ExamGradingKey { examGradingKey :: [Points] -- ^ @[n1, n2, n3, ..., n11]@ means @0 <= p < n1 -> p ~= 5@, @n1 <= p < n2 -> p ~ 4@, @n2 <= p < n3 -> p ~ 3.7@, ..., @n10 <= p -> p ~ 1.0@ diff --git a/src/Utils.hs b/src/Utils.hs index 65b748db9..28c88912d 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -85,6 +85,9 @@ import Algebra.Lattice (top, bottom, (/\), (\/), BoundedJoinSemiLattice, Bounded import Data.Constraint (Dict(..)) +import Control.Monad.Random.Class (MonadRandom) +import qualified System.Random.Shuffle as Rand (shuffleM) + {-# ANN module ("HLint: ignore Use asum" :: String) #-} @@ -953,3 +956,16 @@ clampMin, clampMax :: Ord a -> a -- ^ Clamped Value clampMin = max clampMax = min + +------------ +-- Random -- +------------ + +unstableSortBy :: MonadRandom m => (a -> a -> Ordering) -> [a] -> m [a] +unstableSortBy cmp = fmap concat . mapM Rand.shuffleM . groupBy (\a b -> cmp a b == EQ) . sortBy cmp + +unstableSortOn :: (MonadRandom m, Ord b) => (a -> b) -> [a] -> m [a] +unstableSortOn = unstableSortBy . comparing + +unstableSort :: (MonadRandom m, Ord a) => [a] -> m [a] +unstableSort = unstableSortBy compare diff --git a/src/Yesod/Core/Types/Instances.hs b/src/Yesod/Core/Types/Instances.hs index c5bc29c8b..8af451314 100644 --- a/src/Yesod/Core/Types/Instances.hs +++ b/src/Yesod/Core/Types/Instances.hs @@ -26,6 +26,7 @@ import Control.Monad.Trans.Reader (ReaderT, mapReaderT, runReaderT) import Control.Monad.Base (MonadBase) import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Catch (MonadMask, MonadCatch) +import Control.Monad.Random.Class (MonadRandom) deriving via (ReaderT (HandlerData site site) IO) instance MonadFix (HandlerFor site) @@ -40,6 +41,9 @@ deriving via (ReaderT (WidgetData site) IO) instance MonadMask (WidgetFor site) deriving via (ReaderT (HandlerData site site) IO) instance MonadBase IO (HandlerFor site) deriving via (ReaderT (WidgetData site) IO) instance MonadBase IO (WidgetFor site) +deriving via (ReaderT (HandlerData site site) IO) instance MonadRandom (HandlerFor site) +deriving via (ReaderT (WidgetData site) IO) instance MonadRandom (WidgetFor site) + -- | Type-level tags for compatability of Yesod `cached`-System with `MonadMemo` newtype CachedMemoT k v m a = CachedMemoT { runCachedMemoT' :: ReaderT Loc m a } diff --git a/templates/course/applications-list.hamlet b/templates/course/applications-list.hamlet index 9cb6253fc..fde01d6e1 100644 --- a/templates/course/applications-list.hamlet +++ b/templates/course/applications-list.hamlet @@ -1,22 +1,28 @@ $newline never $if not (null allocationsBounds) -

    _{MsgCourseAllocationsBounds (length allocationsBounds)} -
    - $forall (Allocation{allocationName, allocationRegisterTo}, numApps, numFirstChoice, capped) <- allocationsBounds -
    - #{allocationName} -
    -

    - $if numApps == numFirstChoice - _{MsgCourseAllocationsBoundCoincide numFirstChoice} - $else - _{MsgCourseAllocationsBound numApps numFirstChoice} - $if capped -

    - _{MsgCourseAllocationsBoundCapped} - $if registrationOpen allocationRegisterTo -

    - _{MsgCourseAllocationsBoundWarningOpen} +

    +

    _{MsgCourseAllocationsBounds (length allocationsBounds)} +
    + $forall (Allocation{allocationName, allocationRegisterTo}, numApps, numFirstChoice, capped) <- allocationsBounds +
    + #{allocationName} +
    +

    + $if numApps == numFirstChoice + _{MsgCourseAllocationsBoundCoincide numFirstChoice} + $else + _{MsgCourseAllocationsBound numApps numFirstChoice} + $if capped +

    + _{MsgCourseAllocationsBoundCapped} + $if registrationOpen allocationRegisterTo +

    + _{MsgCourseAllocationsBoundWarningOpen} +$if mayAccept +

    +

    _{MsgBtnAcceptApplicationsTip} + ^{acceptWgt} -

    _{MsgMenuCourseApplications} -^{table} +
    +

    _{MsgMenuCourseApplications} + ^{table} diff --git a/templates/messages/courseInvitationAlreadyRegistered.hamlet b/templates/messages/courseInvitationAlreadyRegistered.hamlet index bf0d3af6b..ba9c16c59 100644 --- a/templates/messages/courseInvitationAlreadyRegistered.hamlet +++ b/templates/messages/courseInvitationAlreadyRegistered.hamlet @@ -1,5 +1,5 @@

    _{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}
      - $forall email <- aurAlreadyRegistered + $forall email <- aurAlreadyRegistered'
    • #{email} diff --git a/templates/messages/courseInvitationRegisteredWithoutField.hamlet b/templates/messages/courseInvitationRegisteredWithoutField.hamlet index cad133fcb..a03358c00 100644 --- a/templates/messages/courseInvitationRegisteredWithoutField.hamlet +++ b/templates/messages/courseInvitationRegisteredWithoutField.hamlet @@ -1,5 +1,5 @@

      _{MsgCourseParticipantsRegisteredWithoutField (length aurNoUniquePrimaryField)}
        - $forall email <- aurNoUniquePrimaryField + $forall email <- aurNoUniquePrimaryField'
      • #{email} From 60a7bb2b194e47e924f56d9f461f07e17cea3f5e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 27 Sep 2019 11:50:31 +0200 Subject: [PATCH 22/38] fix: bump changelog --- templates/i18n/changelog/de.hamlet | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/templates/i18n/changelog/de.hamlet b/templates/i18n/changelog/de.hamlet index 004420443..866cb0f55 100644 --- a/templates/i18n/changelog/de.hamlet +++ b/templates/i18n/changelog/de.hamlet @@ -1,5 +1,11 @@ $newline never
        +
        + ^{formatGregorianW 2019 09 27} +
        +
          +
        • Automatische Anmeldung von Bewerbern in Kursen, die nicht an einer Zentralanmeldung teilnehmen (nach Bewertung der Bewerbung) +
          ^{formatGregorianW 2019 09 25}
          From d27eb5c59bb734d266625e9bf13e4b14c3d4ab1b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 27 Sep 2019 12:01:29 +0200 Subject: [PATCH 23/38] chore(release): 7.2.0 --- CHANGELOG.md | 15 +++++++++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 18 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 358407fc7..049afb2e1 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,21 @@ 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. +## [7.2.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.1.2...v7.2.0) (2019-09-27) + + +### Bug Fixes + +* bump changelog ([60a7bb2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/60a7bb2)) +* don't treat ExamBonusManual as override ([16abcd2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/16abcd2)) + + +### Features + +* **course-applications:** automatic acceptance of direct applicants ([620950d](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/620950d)) + + + ### [7.1.2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.1.1...v7.1.2) (2019-09-26) diff --git a/package-lock.json b/package-lock.json index 688e709db..bfceed21b 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "7.1.2", + "version": "7.2.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 49dde0422..b6a56da62 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "7.1.2", + "version": "7.2.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index d0d6be148..9d968f6cb 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 7.1.2 +version: 7.2.0 dependencies: - base >=4.9.1.0 && <5 From d2ba173776a6caa84ae53e6f87245205e344fa40 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 28 Sep 2019 13:07:44 +0200 Subject: [PATCH 24/38] fix: fix tutorial registration group applying globally --- src/Foundation.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index a9d2d1df0..0fbdd36af 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1197,10 +1197,11 @@ tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of (Nothing, _) -> return Authorized (_, Nothing) -> return AuthenticationRequired (Just rGroup, Just uid) -> do - [E.Value hasOther] <- $cachedHereBinary (uid, rGroup) . lift . E.select . return . E.exists . E.from $ \(tutorial `E.InnerJoin` participant) -> do + [E.Value hasOther] <- $cachedHereBinary (uid, rGroup) . lift . E.selectExists . E.from $ \(tutorial `E.InnerJoin` participant) -> do E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial - E.where_ $ participant E.^. TutorialParticipantUser E.==. E.val uid - E.&&. tutorial E.^. TutorialRegGroup E.==. E.just (E.val rGroup) + E.&&. tutorial E.^. TutorialCourse E.==. E.val tutorialCourse + E.&&. tutorial E.^. TutorialRegGroup E.==. E.just (E.val rGroup) + E.&&. participant E.^. TutorialParticipantUser E.==. E.val uid guard $ not hasOther return Authorized r -> $unsupportedAuthPredicate AuthRegisterGroup r From 69f4a80dc18c58e5980251d3932b469004abe8c1 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 28 Sep 2019 13:18:08 +0200 Subject: [PATCH 25/38] fix: fix build --- src/Foundation.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index 0fbdd36af..42ddd0570 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1197,7 +1197,7 @@ tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of (Nothing, _) -> return Authorized (_, Nothing) -> return AuthenticationRequired (Just rGroup, Just uid) -> do - [E.Value hasOther] <- $cachedHereBinary (uid, rGroup) . lift . E.selectExists . E.from $ \(tutorial `E.InnerJoin` participant) -> do + hasOther <- $cachedHereBinary (uid, rGroup) . lift . E.selectExists . E.from $ \(tutorial `E.InnerJoin` participant) -> do E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial E.&&. tutorial E.^. TutorialCourse E.==. E.val tutorialCourse E.&&. tutorial E.^. TutorialRegGroup E.==. E.just (E.val rGroup) From dce89c215c2b9096eea6159ad51d8f66c723a5d9 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 28 Sep 2019 13:48:20 +0200 Subject: [PATCH 26/38] chore(release): 7.2.1 --- CHANGELOG.md | 10 ++++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 13 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 049afb2e1..3dfe8119a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,16 @@ 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. +### [7.2.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.2.0...v7.2.1) (2019-09-28) + + +### Bug Fixes + +* fix build ([69f4a80](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/69f4a80)) +* fix tutorial registration group applying globally ([d2ba173](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d2ba173)) + + + ## [7.2.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.1.2...v7.2.0) (2019-09-27) diff --git a/package-lock.json b/package-lock.json index bfceed21b..35bd25ba1 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "7.2.0", + "version": "7.2.1", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index b6a56da62..8fa3a4888 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "7.2.0", + "version": "7.2.1", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 9d968f6cb..03ef53037 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 7.2.0 +version: 7.2.1 dependencies: - base >=4.9.1.0 && <5 From c8e1d51e252e037daa72aaf058239091694af74a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 30 Sep 2019 08:06:56 +0200 Subject: [PATCH 27/38] fix(authorisation): keep showing allocations (ro) to lecturers --- src/Foundation.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index 42ddd0570..ffe1d32b1 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -933,7 +933,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of return Authorized r -> $unsupportedAuthPredicate AuthTime r -tagAccessPredicate AuthStaffTime = APDB $ \_ route _ -> case route of +tagAccessPredicate AuthStaffTime = APDB $ \_ route isWrite -> case route of CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course @@ -944,7 +944,8 @@ tagAccessPredicate AuthStaffTime = APDB $ \_ route _ -> case route of Just Allocation{..} -> do cTime <- liftIO getCurrentTime guard $ NTop allocationStaffAllocationFrom <= NTop (Just cTime) - guard $ NTop (Just cTime) <= NTop allocationStaffAllocationTo + when isWrite $ + guard $ NTop (Just cTime) <= NTop allocationStaffAllocationTo return Authorized From bfade4dd5d302c54c2343fb6da4ad88601e32ab9 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 30 Sep 2019 08:17:49 +0200 Subject: [PATCH 28/38] chore(release): 7.2.2 --- CHANGELOG.md | 9 +++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 12 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 3dfe8119a..f042f2dcd 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,15 @@ 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. +### [7.2.2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.2.1...v7.2.2) (2019-09-30) + + +### Bug Fixes + +* **authorisation:** keep showing allocations (ro) to lecturers ([c8e1d51](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/c8e1d51)) + + + ### [7.2.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.2.0...v7.2.1) (2019-09-28) diff --git a/package-lock.json b/package-lock.json index 35bd25ba1..11a08f381 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "7.2.1", + "version": "7.2.2", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 8fa3a4888..cee36112f 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "7.2.1", + "version": "7.2.2", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 03ef53037..ee40ae937 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 7.2.1 +version: 7.2.2 dependencies: - base >=4.9.1.0 && <5 From 64f771518ede9e1b11aaeeaaeb3a2e7d449a13ed Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 30 Sep 2019 08:57:33 +0200 Subject: [PATCH 29/38] fix(course-application): better display of priorities --- src/Handler/Allocation/Application.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs index d9e48239a..912fd8450 100644 --- a/src/Handler/Allocation/Application.hs +++ b/src/Handler/Allocation/Application.hs @@ -82,8 +82,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf coursesNum <- fromIntegral . fromMaybe 1 <$> for maId (\aId -> count [AllocationCourseAllocation ==. aId]) course <- getJust cid (fromMaybe 0 -> maxPrio) <- fmap ((>>= E.unValue) . listToMaybe) . E.select . E.from $ \courseApplication -> do - E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid - E.&&. courseApplication E.^. CourseApplicationUser E.==. E.val uid + E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val uid E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.val maId E.&&. E.not_ (E.isNothing $ courseApplication E.^. CourseApplicationAllocationPriority) return . E.joinV . E.max_ $ courseApplication E.^. CourseApplicationAllocationPriority From 95ceeddc83ff79dad6f2dc494015e85f2996c40d Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 30 Sep 2019 15:53:29 +0200 Subject: [PATCH 30/38] feat(csv): allow customisation of csv-export-options --- messages/uniworx/de.msg | 30 ++++++- models/users | 1 + routes | 1 + src/Foundation.hs | 3 + src/Handler/Profile.hs | 31 ++++++- src/Handler/Users/Add.hs | 1 + src/Handler/Utils/Csv.hs | 33 +++---- src/Handler/Utils/Form.hs | 88 +++++++++++++++++-- src/Handler/Utils/Table/Pagination.hs | 1 + src/Handler/Utils/Widgets.hs | 6 ++ src/Model/Types/Misc.hs | 80 +++++++++++++++++ src/Utils.hs | 3 +- src/Utils/Form.hs | 29 +++--- src/Yesod/Core/Types/Instances.hs | 9 +- .../table/csv-import-explanation/de.hamlet | 33 ++++--- templates/table/csv-transcode.hamlet | 2 + test/Database.hs | 6 ++ test/FoundationSpec.hs | 5 +- test/Model/MigrationSpec.hs | 12 +++ test/Model/TypesSpec.hs | 34 +++++++ test/ModelSpec.hs | 10 ++- test/TestImport.hs | 1 + 22 files changed, 367 insertions(+), 52 deletions(-) create mode 100644 test/Model/MigrationSpec.hs diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index f6bb5cfa4..02c290484 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1499,8 +1499,8 @@ Proportion c@Text of@Text prop@Rational: #{c}/#{of} (#{rationalToFixed2 (100 * p ExamUserCsvName tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase examn}-teilnehmer CourseApplicationsTableCsvName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-bewerbungen -CsvColumnsExplanationsLabel: Spalten -CsvColumnsExplanationsTip: Bedeutung der in der CSV-Datei enthaltenen Spalten +CsvColumnsExplanationsLabel: Spalten- & Zellenformat +CsvColumnsExplanationsTip: Bedeutung und Format der in der CSV-Datei enthaltenen Spalten CsvColumnExamUserSurname: Nachname(n) des Teilnehmers CsvColumnExamUserFirstName: Vorname(n) des Teilnehmers CsvColumnExamUserName: Voller Name des Teilnehmers (gewöhnlicherweise inkl. Vor- und Nachname(n)) @@ -1797,4 +1797,28 @@ AcceptApplicationsInvite: Einladungen verschicken AcceptApplicationsSecondary: Gleichstände auflösen AcceptApplicationsSecondaryTip: Wenn es im Laufe des Verfahrens mehrere Bewerber mit der selben Bewertung für den selben Platz gibt, wie soll der Gleichstand aufgelöst werden? AcceptApplicationsSecondaryRandom: Zufällig -AcceptApplicationsSecondaryTime: Nach Zeitpunkt der Bewerbung \ No newline at end of file +AcceptApplicationsSecondaryTime: Nach Zeitpunkt der Bewerbung + +CsvOptions: CSV-Optionen +CsvOptionsTip: Diese Einstellungen betreffen nur den CSV-Export; beim Import werden die verwendeten Einstellungen automatisch ermittelt. +CsvPresetRFC: Standard-Konform (RFC 4180) +CsvPresetExcel: Excel-Kompatibel +CsvCustom: Benutzerdefiniert +CsvDelimiter: Trennzeichen +CsvUseCrLf: Zeilenumbrüche +CsvQuoting: Quoting +CsvQuotingTip: Wann sollen Anführungszeichen (") um Felder platziert werden, um Interpretation von im Feld enthaltenen Zeichen als Trennzeichen zu verhindern? +CsvDelimiterNull: Null-Byte +CsvDelimiterTab: Tabulator +CsvDelimiterComma: Komma +CsvDelimiterColon: Doppelpunkt +CsvDelimiterBar: Senkrechter Strich +CsvDelimiterSpace: Leerzeichen +CsvDelimiterUnitSep: Teilgruppentrennzeichen +CsvCrLf: DOS (CRLF) +CsvLf: Unix (LF) +CsvQuoteNone: Nie +CsvQuoteMinimal: Nur wenn nötig +CsvQuoteAll: Immer +CsvOptionsUpdated: CSV-Optionen erfolgreich angepasst +CsvChangeOptionsLabel: Export-Optionen \ No newline at end of file diff --git a/models/users b/models/users index 22c14f1dc..14c0ddc2e 100644 --- a/models/users +++ b/models/users @@ -30,6 +30,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create mailLanguages MailLanguages "default='[]'::jsonb" -- Preferred language for eMail; i18n not yet implemented; user-defined notificationSettings NotificationSettings -- Bit-array for which events email notifications are requested by user; user-defined warningDays NominalDiffTime default=1209600 -- timedistance to pending deadlines for homepage infos + csvOptions CsvOptions "default='{}'::jsonb" UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table UniqueEmail email -- Column 'email' can be used as a row-key in this table deriving Show Eq Ord Generic -- Haskell-specific settings for runtime-value representing a row in memory diff --git a/routes b/routes index 79b77524e..f056b1f98 100644 --- a/routes +++ b/routes @@ -72,6 +72,7 @@ /user/profile ProfileDataR GET !free /user/authpreds AuthPredsR GET POST !free /user/set-display-email SetDisplayEmailR GET POST !free +/user/csv-options CsvOptionsR GET POST !free /exam-office ExamOfficeR !exam-office: / EOExamsR GET diff --git a/src/Foundation.hs b/src/Foundation.hs index ffe1d32b1..e3de692ef 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -315,6 +315,8 @@ embedRenderMessage ''UniWorX ''UploadModeDescr id embedRenderMessage ''UniWorX ''SecretJSONFieldException id embedRenderMessage ''UniWorX ''AFormMessage $ concat . drop 2 . splitCamel embedRenderMessage ''UniWorX ''SchoolFunction id +embedRenderMessage ''UniWorX ''CsvPreset id +embedRenderMessage ''UniWorX ''Quoting ("Csv" <>) embedRenderMessage ''UniWorX ''AuthenticationMode id @@ -3287,6 +3289,7 @@ upsertCampusUser ldapData Creds{..} = do , userWarningDays = userDefaultWarningDays , userNotificationSettings = def , userMailLanguages = def + , userCsvOptions = def , userTokensIssuedAfter = Nothing , userCreated = now , userLastLdapSynchronisation = Just now diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 13a0e9c81..57a49c428 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -1,4 +1,11 @@ -module Handler.Profile where +module Handler.Profile + ( getProfileR, postProfileR + , getProfileDataR, makeProfileData + , getAuthPredsR, postAuthPredsR + , getUserNotificationR, postUserNotificationR + , getSetDisplayEmailR, postSetDisplayEmailR + , getCsvOptionsR, postCsvOptionsR + ) where import Import @@ -796,3 +803,25 @@ postSetDisplayEmailR = do siteLayoutMsg MsgTitleChangeUserDisplayEmail $ do setTitleI MsgTitleChangeUserDisplayEmail $(i18nWidgetFile "set-display-email") + +getCsvOptionsR, postCsvOptionsR :: Handler Html +getCsvOptionsR = postCsvOptionsR +postCsvOptionsR = do + Entity uid User{userCsvOptions} <- requireAuth + + ((optionsRes, optionsWgt'), optionsEnctype) <- runFormPost . renderAForm FormStandard $ + csvOptionsForm (fslI MsgCsvOptions & setTooltip MsgCsvOptionsTip) (Just userCsvOptions) + + formResultModal optionsRes CsvOptionsR $ \opts -> do + lift . runDB $ update uid [ UserCsvOptions =. opts ] + tell . pure =<< messageI Success MsgCsvOptionsUpdated + + siteLayoutMsg MsgCsvOptions $ do + setTitleI MsgCsvOptions + + isModal <- hasCustomHeader HeaderIsModal + wrapForm optionsWgt' def + { formAction = Just $ SomeRoute CsvOptionsR + , formEncoding = optionsEnctype + , formAttrs = [ asyncSubmitAttr | isModal ] + } diff --git a/src/Handler/Users/Add.hs b/src/Handler/Users/Add.hs index b8e6efd35..897fbd1ca 100644 --- a/src/Handler/Users/Add.hs +++ b/src/Handler/Users/Add.hs @@ -73,6 +73,7 @@ postAdminUserAddR = do , userWarningDays = userDefaultWarningDays , userNotificationSettings = def , userMailLanguages = def + , userCsvOptions = def , userTokensIssuedAfter = Nothing , userCreated = now , userLastLdapSynchronisation = Nothing diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index ff84ddfb9..926879254 100644 --- a/src/Handler/Utils/Csv.hs +++ b/src/Handler/Utils/Csv.hs @@ -98,19 +98,23 @@ decodeCsv = transPipe throwExceptT $ do encodeCsv :: ( ToNamedRecord csv - , Monad m + , MonadHandler m + , HandlerSite m ~ UniWorX ) => Header -> ConduitT csv ByteString m () -- ^ Encode a stream of records -- -- Currently not streaming -encodeCsv hdr = fmap (encodeByName hdr) (C.foldMap pure) >>= C.sourceLazy +encodeCsv hdr = do + csvOpts <- fmap (maybe def (userCsvOptions . entityVal)) . lift $ liftHandler maybeAuth + fmap (encodeByNameWith (csvOpts ^. _CsvEncodeOptions) hdr) (C.foldMap pure) >>= C.sourceLazy encodeDefaultOrderedCsv :: forall csv m. ( ToNamedRecord csv , DefaultOrdered csv - , Monad m + , MonadHandler m + , HandlerSite m ~ UniWorX ) => ConduitT csv ByteString m () encodeDefaultOrderedCsv = encodeCsv $ headerOrder (error "headerOrder" :: csv) @@ -118,33 +122,32 @@ encodeDefaultOrderedCsv = encodeCsv $ headerOrder (error "headerOrder" :: csv) respondCsv :: ToNamedRecord csv => Header - -> ConduitT () csv (HandlerFor site) () - -> HandlerFor site TypedContent + -> ConduitT () csv Handler () + -> Handler TypedContent respondCsv hdr src = respondSource typeCsv' $ src .| encodeCsv hdr .| awaitForever sendChunk -respondDefaultOrderedCsv :: forall csv site. +respondDefaultOrderedCsv :: forall csv. ( ToNamedRecord csv , DefaultOrdered csv ) - => ConduitT () csv (HandlerFor site) () - -> HandlerFor site TypedContent + => ConduitT () csv Handler () + -> Handler TypedContent respondDefaultOrderedCsv = respondCsv $ headerOrder (error "headerOrder" :: csv) respondCsvDB :: ( ToNamedRecord csv - , YesodPersistRunner site + , YesodPersistRunner UniWorX ) => Header - -> ConduitT () csv (YesodDB site) () - -> HandlerFor site TypedContent + -> ConduitT () csv DB () + -> Handler TypedContent respondCsvDB hdr src = respondSourceDB typeCsv' $ src .| encodeCsv hdr .| awaitForever sendChunk -respondDefaultOrderedCsvDB :: forall csv site. +respondDefaultOrderedCsvDB :: forall csv. ( ToNamedRecord csv , DefaultOrdered csv - , YesodPersistRunner site ) - => ConduitT () csv (YesodDB site) () - -> HandlerFor site TypedContent + => ConduitT () csv DB () + -> Handler TypedContent respondDefaultOrderedCsvDB = respondCsvDB $ headerOrder (error "headerOrder" :: csv) fileSourceCsv :: ( FromNamedRecord csv diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 2f8af499c..f0573a00f 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -12,6 +12,7 @@ import Handler.Utils.Form.Types import Handler.Utils.DateTime import Import +import Data.Char (chr, ord) import qualified Data.Char as Char import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI @@ -220,11 +221,7 @@ multiAction :: forall action a. -> Maybe action -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) multiAction acts fs@FieldSettings{..} defAction csrf = do - mr <- getMessageRender - - let - options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece - (actionRes, actionView) <- mreq (selectField $ return options) fs defAction + (actionRes, actionView) <- mreq (selectField . optionsF $ Map.keysSet acts) fs defAction results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts let actionResults = view _1 <$> results @@ -1199,3 +1196,84 @@ examPassedField :: forall m. ) => Field m ExamPassed examPassedField = hoistField liftHandler $ selectField optionsFinite + + +data CsvOptions' = CsvOptionsPreset' CsvPreset + | CsvOptionsCustom' + deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveFinite ''CsvOptions' +instance PathPiece CsvOptions' where + toPathPiece = \case + CsvOptionsPreset' p -> toPathPiece p + CsvOptionsCustom' -> "custom" + fromPathPiece t = fromPathPiece t + <|> guardOn (t == "custom") CsvOptionsCustom' +instance RenderMessage UniWorX CsvOptions' where + renderMessage m ls = \case + CsvOptionsPreset' p -> mr p + CsvOptionsCustom' -> mr MsgCsvCustom + where + mr :: forall msg. RenderMessage UniWorX msg => msg -> Text + mr = renderMessage m ls + +csvOptionsForm :: forall m. + ( MonadHandler m + , HandlerSite m ~ UniWorX + ) + => FieldSettings UniWorX + -> Maybe CsvOptions + -> AForm m CsvOptions +csvOptionsForm fs mPrev = hoistAForm liftHandler . multiActionA csvActs fs $ classifyCsvOptions <$> mPrev + where + csvActs :: Map CsvOptions' (AForm Handler CsvOptions) + csvActs = mapF $ \case + CsvOptionsPreset' preset + -> pure $ csvPreset # preset + CsvOptionsCustom' + -> CsvOptions + <$> areq (selectField delimiterOpts) (fslI MsgCsvDelimiter) (csvDelimiter <$> mPrev) + <*> areq (selectField lineEndOpts) (fslI MsgCsvUseCrLf) (csvUseCrLf <$> mPrev) + <*> areq (selectField quoteOpts) (fslI MsgCsvQuoting & setTooltip MsgCsvQuotingTip) (csvQuoting <$> mPrev) + + delimiterOpts :: Handler (OptionList Char) + delimiterOpts = do + MsgRenderer mr <- getMsgRenderer + let + opts = + [ (MsgCsvDelimiterNull, '\0') + , (MsgCsvDelimiterTab, '\t') + , (MsgCsvDelimiterComma, ',') + , (MsgCsvDelimiterColon, chr 58) + , (MsgCsvDelimiterBar, '|') + , (MsgCsvDelimiterSpace, ' ') + , (MsgCsvDelimiterUnitSep, chr 31) + ] + olReadExternal t = do + i <- readMay t + guard $ i >= 0 && i <= 255 + let c = chr i + guard $ any ((== c) . view _2) opts + return c + olOptions = [ Option (mr msg) c (tshow $ ord c) + | (msg, c) <- opts + ] + return OptionList{..} + + lineEndOpts :: Handler (OptionList Bool) + lineEndOpts = optionsPathPiece + [ (MsgCsvCrLf, True ) + , (MsgCsvLf, False) + ] + + quoteOpts :: Handler (OptionList Quoting) + quoteOpts = optionsF + [ QuoteMinimal + , QuoteAll + ] + + classifyCsvOptions :: CsvOptions -> CsvOptions' + classifyCsvOptions opts + | Just preset <- opts ^? csvPreset + = CsvOptionsPreset' preset + | otherwise + = CsvOptionsCustom' diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index a17fe31d1..a268d550a 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -49,6 +49,7 @@ import Handler.Utils.Form import Handler.Utils.Csv import Handler.Utils.ContentDisposition import Handler.Utils.I18n +import Handler.Utils.Widgets import Utils import Utils.Lens diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index 01a2c6f01..994fe893d 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -96,3 +96,9 @@ editedByW fmt tm usr = do heat :: Integral a => a -> a -> Double heat (toInteger -> full) (toInteger -> achieved) = roundToDigits 3 $ cutOffPercent 0.3 (fromIntegral full^2) (fromIntegral achieved^2) + +i18n :: forall m msg. + ( MonadWidget m + , RenderMessage (HandlerSite m) msg + ) => msg -> m () +i18n = toWidget . (SomeMessage :: msg -> SomeMessage (HandlerSite m)) diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index f21c55ecb..7d20c7bca 100644 --- a/src/Model/Types/Misc.hs +++ b/src/Model/Types/Misc.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + {-| Module: Model.Types.Misc Description: Additional uncategorized types @@ -5,6 +7,7 @@ Description: Additional uncategorized types module Model.Types.Misc ( module Model.Types.Misc + , Quoting(..) ) where import Import.NoModel @@ -14,6 +17,11 @@ import Data.Maybe (fromJust) import qualified Data.Text as Text import qualified Data.Text.Lens as Text +import Data.Csv (Quoting(..)) +import qualified Data.Csv as Csv + +import qualified Data.Aeson as JSON + data StudyFieldType = FieldPrimary | FieldSecondary deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic) @@ -43,3 +51,75 @@ nullaryPathPiece ''Theme $ camelToPathPiece' 1 $(deriveSimpleWith ''ToMessage 'toMessage (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user derivePersistField "Theme" + + +deriving instance Generic Quoting +deriving instance Ord Quoting +deriving instance Read Quoting +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + } ''Quoting +deriveFinite ''Quoting +nullaryPathPiece ''Quoting $ \q -> if + | q == "QuoteNone" -> "never" + | otherwise -> camelToPathPiece' 1 q + +data CsvOptions + = CsvOptions + { csvDelimiter :: Char + , csvUseCrLf :: Bool + , csvQuoting :: Csv.Quoting + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance Default CsvOptions where + def = csvPreset # CsvPresetRFC + +data CsvPreset = CsvPresetRFC + | CsvPresetExcel + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe CsvPreset +instance Finite CsvPreset + +csvPreset :: Prism' CsvOptions CsvPreset +csvPreset = prism' fromPreset toPreset + where + fromPreset :: CsvPreset -> CsvOptions + fromPreset CsvPresetRFC = CsvOptions { csvDelimiter = ',', csvUseCrLf = True, csvQuoting = QuoteMinimal } + fromPreset CsvPresetExcel = CsvOptions { csvDelimiter = ';', csvUseCrLf = True, csvQuoting = QuoteAll } + + toPreset :: CsvOptions -> Maybe CsvPreset + toPreset opts = case filter (\p -> fromPreset p == opts) universeF of + [p] -> Just p + _other -> Nothing + +_CsvEncodeOptions :: Iso' CsvOptions Csv.EncodeOptions +_CsvEncodeOptions = iso toEncode fromEncode + where + toEncode CsvOptions{..} = Csv.defaultEncodeOptions + { Csv.encDelimiter = fromIntegral $ fromEnum csvDelimiter + , Csv.encUseCrLf = csvUseCrLf + , Csv.encQuoting = csvQuoting + , Csv.encIncludeHeader = True + } + fromEncode encOpts = CsvOptions + { csvDelimiter = toEnum . fromIntegral $ Csv.encDelimiter encOpts + , csvUseCrLf = Csv.encUseCrLf encOpts + , csvQuoting = Csv.encQuoting encOpts + } + +instance ToJSON CsvOptions where + toJSON CsvOptions{..} = JSON.object + [ "delimiter" JSON..= fromEnum csvDelimiter + , "use-cr-lf" JSON..= csvUseCrLf + , "quoting" JSON..= csvQuoting + ] +instance FromJSON CsvOptions where + parseJSON = JSON.withObject "CsvOptions" $ \o -> do + csvDelimiter <- fmap (fmap toEnum) (o JSON..:? "delimiter") JSON..!= csvDelimiter def + csvUseCrLf <- o JSON..:? "use-cr-lf" JSON..!= csvUseCrLf def + csvQuoting <- o JSON..:? "quoting" JSON..!= csvQuoting def + return CsvOptions{..} +derivePersistFieldJSON ''CsvOptions + +nullaryPathPiece ''CsvPreset $ camelToPathPiece' 2 diff --git a/src/Utils.hs b/src/Utils.hs index 28c88912d..82c19d0b2 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -412,7 +412,8 @@ mapSymmDiff a b = Map.fromListWith Set.union . map (over _2 Set.singleton) . Set assocsSet :: Ord (k, v) => Map k v -> Set (k, v) assocsSet = setOf folded . imap (,) - +mapF :: (Ord k, Finite k) => (k -> v) -> Map k v +mapF = flip Map.fromSet $ Set.fromList universeF --------------- -- Functions -- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 31bc5ad08..80a4443db 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -491,6 +491,24 @@ reorderField optList = Field{..} withNum t n = tshow n <> "." <> t $(widgetFile "widgets/permutation/permutation") +optionsPathPiece :: ( MonadHandler m + , HandlerSite m ~ site + , MonoFoldable mono + , Element mono ~ (msg, val) + , RenderMessage site msg + , PathPiece val + ) + => mono -> m (OptionList val) +optionsPathPiece (otoList -> opts) = do + mr <- getMessageRender + let + mkOption (m, a) = Option + { optionDisplay = mr m + , optionInternalValue = a + , optionExternalValue = toPathPiece a + } + return . mkOptionList $ mkOption <$> opts + optionsF :: ( MonadHandler m , RenderMessage site (Element mono) , HandlerSite m ~ site @@ -498,16 +516,7 @@ optionsF :: ( MonadHandler m , MonoFoldable mono ) => mono -> m (OptionList (Element mono)) -optionsF (otoList -> opts) = do - mr <- getMessageRender - let - mkOption a = Option - { optionDisplay = mr a - , optionInternalValue = a - , optionExternalValue = toPathPiece a - } - return . mkOptionList $ mkOption <$> opts - +optionsF = optionsPathPiece . map (id &&& id) . otoList optionsFinite :: ( MonadHandler m , Finite a diff --git a/src/Yesod/Core/Types/Instances.hs b/src/Yesod/Core/Types/Instances.hs index 8af451314..faac3b4a3 100644 --- a/src/Yesod/Core/Types/Instances.hs +++ b/src/Yesod/Core/Types/Instances.hs @@ -27,6 +27,7 @@ import Control.Monad.Base (MonadBase) import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Catch (MonadMask, MonadCatch) import Control.Monad.Random.Class (MonadRandom) +import Control.Monad.Morph (MFunctor, MMonad) deriving via (ReaderT (HandlerData site site) IO) instance MonadFix (HandlerFor site) @@ -52,6 +53,7 @@ newtype CachedMemoT k v m a = CachedMemoT { runCachedMemoT' :: ReaderT Loc m a } , MonadThrow, MonadCatch, MonadMask, MonadLogger, MonadLoggerIO , MonadResource, MonadHandler, MonadWidget ) + deriving newtype ( MFunctor, MMonad, MonadTrans ) deriving newtype instance MonadBase b m => MonadBase b (CachedMemoT k v m) deriving newtype instance MonadBaseControl b m => MonadBaseControl b (CachedMemoT k v m) @@ -60,7 +62,8 @@ instance MonadReader r m => MonadReader r (CachedMemoT k v m) where reader = CachedMemoT . lift . reader local f (CachedMemoT act) = CachedMemoT $ mapReaderT (local f) act -deriving via (ReaderT Loc) instance MonadTrans (CachedMemoT k v) +instance MonadUnliftIO m => MonadUnliftIO (CachedMemoT k v m) where + askUnliftIO = (\UnliftIO{..} -> UnliftIO $ \(CachedMemoT f) -> unliftIO f) <$> CachedMemoT askUnliftIO -- | Uses `cachedBy` with a `Binary`-encoded @k@ @@ -73,3 +76,7 @@ runCachedMemoT :: Q Exp runCachedMemoT = do loc <- location [e| flip runReaderT loc . runCachedMemoT' |] + + +instance site ~ site' => ToWidget site (SomeMessage site') where + toWidget msg = toWidget =<< (getMessageRender <*> pure msg) diff --git a/templates/i18n/table/csv-import-explanation/de.hamlet b/templates/i18n/table/csv-import-explanation/de.hamlet index ba415fd30..33d4609ef 100644 --- a/templates/i18n/table/csv-import-explanation/de.hamlet +++ b/templates/i18n/table/csv-import-explanation/de.hamlet @@ -1,12 +1,23 @@ +$newline never

          Hinweise zum Import von CSV-Dateien
          +
          Datenformat +
          + Beim Import wird, pro Spalte, das selbe Datenformat erwartet, wie es beim # + Export produziert wird (siehe Spalten- & Zellenformat # + unter CSV-Export).
          + Spalten können beliebig permutiert werden und dürfen auch fehlen (in # + diesem Fall wird die fehlende Spalte so behandelt als enthielte sie in # + jeder Zeile eine leere Zelle).
          + Spalten werden an ihrer Überschrift identifiziert. # + Die Überschrift darf daher nicht verändert oder entfernt werden.
          Änderungen
          - Einige Zellen können durch den Import verändert werden. + 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. + 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
          @@ -16,22 +27,22 @@

          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. + Daraus folgt, dass es sinnvoll sein kann, gewisse Zellen frei zu lassen; # + ändert man z.B. die Studienfachzuordnung eines Teilnehmers ab, # + so müsste man auch Abschluss und Fachsemester 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. + 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; + Es können auch neue Zeilen hinzugefügt werden, sofern 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 + 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 92e1ea95a..b2b7a2a7b 100644 --- a/templates/table/csv-transcode.hamlet +++ b/templates/table/csv-transcode.hamlet @@ -14,5 +14,7 @@ $if is _Just dbtCsvEncode

          ^{csvColExplanations'} +

          + ^{modal (i18n MsgCsvChangeOptionsLabel) (Left (SomeRoute CsvOptionsR))} ^{csvExportWdgt'} diff --git a/test/Database.hs b/test/Database.hs index 140f0e490..78416f2fe 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -111,6 +111,7 @@ fillDb = do , userNotificationSettings = def , userCreated = now , userLastLdapSynchronisation = Nothing + , userCsvOptions = csvPreset # CsvPresetRFC } fhamann <- insert User { userIdent = "felix.hamann@campus.lmu.de" @@ -135,6 +136,7 @@ fillDb = do , userNotificationSettings = def , userCreated = now , userLastLdapSynchronisation = Nothing + , userCsvOptions = csvPreset # CsvPresetExcel } jost <- insert User { userIdent = "jost@tcs.ifi.lmu.de" @@ -159,6 +161,7 @@ fillDb = do , userNotificationSettings = def , userCreated = now , userLastLdapSynchronisation = Nothing + , userCsvOptions = def } maxMuster <- insert User { userIdent = "max@campus.lmu.de" @@ -183,6 +186,7 @@ fillDb = do , userNotificationSettings = def , userCreated = now , userLastLdapSynchronisation = Nothing + , userCsvOptions = def } tinaTester <- insert $ User { userIdent = "tester@campus.lmu.de" @@ -207,6 +211,7 @@ fillDb = do , userNotificationSettings = def , userCreated = now , userLastLdapSynchronisation = Nothing + , userCsvOptions = def } svaupel <- insert User { userIdent = "vaupel.sarah@campus.lmu.de" @@ -231,6 +236,7 @@ fillDb = do , userNotificationSettings = def , userCreated = now , userLastLdapSynchronisation = Nothing + , userCsvOptions = def } void . repsert (TermKey summer2017) $ Term { termName = summer2017 diff --git a/test/FoundationSpec.hs b/test/FoundationSpec.hs index 2386c7ba6..953c65b17 100644 --- a/test/FoundationSpec.hs +++ b/test/FoundationSpec.hs @@ -18,10 +18,11 @@ instance Arbitrary (Route Auth) where instance Arbitrary (Route EmbeddedStatic) where arbitrary = do let printableText = pack . filter (/= '/') . getPrintableString <$> arbitrary + printableText' = printableText `suchThat` (not . null) pathLength <- getPositive <$> arbitrary - path <- replicateM pathLength printableText + path <- replicateM pathLength printableText' paramNum <- getNonNegative <$> arbitrary - params <- replicateM paramNum $ (,) <$> printableText <*> printableText + params <- replicateM paramNum $ (,) <$> printableText' <*> printableText return $ embeddedResourceR path params instance Arbitrary SchoolR where diff --git a/test/Model/MigrationSpec.hs b/test/Model/MigrationSpec.hs new file mode 100644 index 000000000..87d367d74 --- /dev/null +++ b/test/Model/MigrationSpec.hs @@ -0,0 +1,12 @@ +module Model.MigrationSpec where + +import TestImport + +import Model.Migration + + +spec :: Spec +spec = withApp $ -- `withApp` does migration, if needed + describe "Migration" $ + it "is idempotent" $ + (`shouldBe` False) <$> runDB requiresMigration -- Migration shouldn't be needed after `withApp` above diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index c27083034..2aac97b8d 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -8,6 +8,7 @@ import Settings import Control.Lens (review, preview) import Data.Aeson (Value) import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson import MailSpec () @@ -32,6 +33,8 @@ import Data.Scientific import Utils.Lens +import qualified Data.Char as Char + instance (Arbitrary a, MonoFoldable a) => Arbitrary (NonNull a) where arbitrary = arbitrary `suchThatMap` fromNullable @@ -250,6 +253,28 @@ instance Arbitrary ExamPassed where arbitrary = genericArbitrary shrink = genericShrink +instance Arbitrary Quoting where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary CsvOptions where + arbitrary = CsvOptions + <$> suchThat arbitrary validDelimiter + <*> arbitrary + <*> arbitrary + where + validDelimiter c = and + [ Char.isLatin1 c + , c /= '"' + , c /= '\r' + , c /= '\n' + ] + shrink = genericShrink + +instance Arbitrary CsvPreset where + arbitrary = genericArbitrary + shrink = genericShrink + spec :: Spec spec = do @@ -334,6 +359,12 @@ spec = do [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ] lawsCheckHspec (Proxy @ExamPassed) [ eqLaws, ordLaws, showReadLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws, csvFieldLaws ] + lawsCheckHspec (Proxy @Quoting) + [ eqLaws, ordLaws, jsonLaws, showReadLaws, finiteLaws, pathPieceLaws ] + lawsCheckHspec (Proxy @CsvOptions) + [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ] + lawsCheckHspec (Proxy @CsvPreset) + [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, pathPieceLaws ] describe "TermIdentifier" $ do it "has compatible encoding/decoding to/from Text" . property $ @@ -365,6 +396,9 @@ spec = do parse "1.8" `shouldSatisfy` is _Left parse "voided" `shouldBe` Right ExamVoided parse "no-show" `shouldBe` Right ExamNoShow + describe "CsvOptions" $ + it "json-decodes from empty object" . example $ + Aeson.parseMaybe Aeson.parseJSON (Aeson.object []) `shouldBe` Just (def :: CsvOptions) termExample :: (TermIdentifier, Text) -> Expectation termExample (term, encoded) = example $ do diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs index a0139e9a8..a3d8de2c9 100644 --- a/test/ModelSpec.hs +++ b/test/ModelSpec.hs @@ -22,10 +22,13 @@ import Utils import System.FilePath import Data.Time +import Mail (MailLanguages(..)) + + instance Arbitrary EmailAddress where arbitrary = do - local <- suchThat arbitrary (\l -> isEmail l (CBS.pack "example.com")) - domain <- suchThat arbitrary (\d -> isEmail (CBS.pack "example") d) + local <- suchThat (CBS.pack . getPrintableString <$> arbitrary) (\l -> isEmail l (CBS.pack "example.com")) + domain <- suchThat (CBS.pack . getPrintableString <$> arbitrary) (\d -> isEmail (CBS.pack "example") d) let (Just result) = emailAddress (makeEmailLike local domain) pure result @@ -100,8 +103,9 @@ instance Arbitrary User where userDownloadFiles <- arbitrary userWarningDays <- arbitrary - userMailLanguages <- arbitrary + userMailLanguages <- fmap MailLanguages $ sublistOf =<< shuffle (toList appLanguages) userNotificationSettings <- arbitrary + userCsvOptions <- arbitrary userCreated <- arbitrary userLastLdapSynchronisation <- arbitrary diff --git a/test/TestImport.hs b/test/TestImport.hs index d14c8ae07..af8b15be8 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -140,6 +140,7 @@ createUser adjUser = do userNotificationSettings = def userCreated = now userLastLdapSynchronisation = Nothing + userCsvOptions = def runDB . insertEntity $ adjUser User{..} lawsCheckHspec :: Typeable a => Proxy a -> [Proxy a -> Laws] -> Spec From 4c9e635a388cbb1ec9c61f6f78dbfd2c43b9dfb7 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 30 Sep 2019 16:02:48 +0200 Subject: [PATCH 31/38] chore(release): 7.3.0 --- CHANGELOG.md | 14 ++++++++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 17 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index f042f2dcd..334d284ef 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,20 @@ 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. +## [7.3.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.2.2...v7.3.0) (2019-09-30) + + +### Bug Fixes + +* **course-application:** better display of priorities ([64f7715](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/64f7715)) + + +### Features + +* **csv:** allow customisation of csv-export-options ([95ceedd](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/95ceedd)) + + + ### [7.2.2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.2.1...v7.2.2) (2019-09-30) diff --git a/package-lock.json b/package-lock.json index 11a08f381..eef338894 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "7.2.2", + "version": "7.3.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index cee36112f..20a8586e0 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "7.2.2", + "version": "7.3.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index ee40ae937..73af390b8 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 7.2.2 +version: 7.3.0 dependencies: - base >=4.9.1.0 && <5 From d7d1f273036a2dba5113c04319cdf075fbdb829c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 30 Sep 2019 16:18:48 +0200 Subject: [PATCH 32/38] fix(course-edit): edit courses without being school-wide lecturer Fixes #464 --- src/Handler/Course/Edit.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index fcb45369e..a670a8e1f 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -107,12 +107,13 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB MsgRenderer mr <- getMsgRenderer uid <- liftHandler requireAuthId - (lecturerSchools, adminSchools) <- liftHandler . runDB $ do + (lecturerSchools, adminSchools, oldSchool) <- liftHandler . runDB $ do lecturerSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] [] protoAdminSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]] [] adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools - return (lecturerSchools, adminSchools) - let userSchools = nub $ lecturerSchools ++ adminSchools + oldSchool <- forM (cfCourseId =<< template) $ fmap courseSchool . getJust + return (lecturerSchools, adminSchools, oldSchool) + let userSchools = nub . maybe id (:) oldSchool $ lecturerSchools ++ adminSchools termsField <- case template of -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin From ac7f0936471713f528d24f5b83eb5a0c888bc177 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 30 Sep 2019 16:19:35 +0200 Subject: [PATCH 33/38] chore: fix build --- src/Handler/Utils/Csv.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index 926879254..bc0617d29 100644 --- a/src/Handler/Utils/Csv.hs +++ b/src/Handler/Utils/Csv.hs @@ -134,9 +134,7 @@ respondDefaultOrderedCsv :: forall csv. -> Handler TypedContent respondDefaultOrderedCsv = respondCsv $ headerOrder (error "headerOrder" :: csv) -respondCsvDB :: ( ToNamedRecord csv - , YesodPersistRunner UniWorX - ) +respondCsvDB :: ToNamedRecord csv => Header -> ConduitT () csv DB () -> Handler TypedContent From 2a518f328415e7fc37522cc0e3bc98d6c336c3c5 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 30 Sep 2019 16:29:58 +0200 Subject: [PATCH 34/38] chore(release): 7.3.1 --- CHANGELOG.md | 9 +++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 12 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 334d284ef..88f0c833d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,15 @@ 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. +### [7.3.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.3.0...v7.3.1) (2019-09-30) + + +### Bug Fixes + +* **course-edit:** edit courses without being school-wide lecturer ([d7d1f27](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d7d1f27)), closes [#464](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/464) + + + ## [7.3.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.2.2...v7.3.0) (2019-09-30) diff --git a/package-lock.json b/package-lock.json index eef338894..9eb0c401c 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "7.3.0", + "version": "7.3.1", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 20a8586e0..9ae5e8d8f 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "7.3.0", + "version": "7.3.1", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 73af390b8..64a18e649 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 7.3.0 +version: 7.3.1 dependencies: - base >=4.9.1.0 && <5 From 8a688cc7958ac09408eb62ddf0f97f0396545b13 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 30 Sep 2019 16:56:49 +0200 Subject: [PATCH 35/38] refactor(tutorials): split --- src/Handler/Tutorial.hs | 485 +------------------------- src/Handler/Tutorial/Communication.hs | 81 +++++ src/Handler/Tutorial/Delete.hs | 39 +++ src/Handler/Tutorial/Edit.hs | 92 +++++ src/Handler/Tutorial/Form.hs | 96 +++++ src/Handler/Tutorial/List.hs | 87 +++++ src/Handler/Tutorial/New.hs | 60 ++++ src/Handler/Tutorial/Register.hs | 28 ++ src/Handler/Tutorial/TutorInvite.hs | 79 +++++ 9 files changed, 571 insertions(+), 476 deletions(-) create mode 100644 src/Handler/Tutorial/Communication.hs create mode 100644 src/Handler/Tutorial/Delete.hs create mode 100644 src/Handler/Tutorial/Edit.hs create mode 100644 src/Handler/Tutorial/Form.hs create mode 100644 src/Handler/Tutorial/List.hs create mode 100644 src/Handler/Tutorial/New.hs create mode 100644 src/Handler/Tutorial/Register.hs create mode 100644 src/Handler/Tutorial/TutorInvite.hs diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index 94a00e645..04fc02220 100644 --- a/src/Handler/Tutorial.hs +++ b/src/Handler/Tutorial.hs @@ -1,480 +1,13 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - module Handler.Tutorial ( module Handler.Tutorial ) where -import Import -import Handler.Utils -import Handler.Utils.Tutorial -import Handler.Utils.Delete -import Handler.Utils.Communication -import Handler.Utils.Form.Occurrences -import Handler.Utils.Invitations -import Jobs.Queue - -import qualified Database.Esqueleto as E -import qualified Database.Esqueleto.Utils as E -import Database.Esqueleto.Utils.TH - -import Data.Map ((!)) -import qualified Data.Map as Map -import qualified Data.Set as Set - -import qualified Data.CaseInsensitive as CI - -import Data.Aeson hiding (Result(..)) -import Text.Hamlet (ihamlet) - -import Handler.Tutorial.Users as Handler.Tutorial - -{-# ANN module ("Hlint: ignore Redundant void" :: String) #-} - - -getCTutorialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getCTutorialListR tid ssh csh = do - Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh - - let - tutorialDBTable = DBTable{..} - where - dbtSQLQuery tutorial = do - E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid - let participants = E.sub_select . E.from $ \tutorialParticipant -> do - E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId - return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int)) - return (tutorial, participants) - dbtRowKey = (E.^. TutorialId) - dbtProj = return . over (_dbrOutput . _2) E.unValue - dbtColonnade = dbColonnade $ mconcat - [ sortable (Just "type") (i18nCell MsgTutorialType) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell $ CI.original tutorialType - , sortable (Just "name") (i18nCell MsgTutorialName) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|] - , sortable Nothing (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = (Entity tutid _, _) } -> sqlCell $ do - tutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do - E.on $ tutor E.^. TutorUser E.==. user E.^. UserId - E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid - return (user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname) - return [whamlet| - $newline never -

            - $forall tutor <- tutors -
          • - ^{nameEmailWidget' tutor} - |] - , sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, n) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) $ tshow n - , sortable (Just "capacity") (i18nCell MsgTutorialCapacity) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . tshow) tutorialCapacity - , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell tutorialRoom - , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> occurrencesCell tutorialTime - , sortable (Just "register-group") (i18nCell MsgTutorialRegGroup) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . CI.original) tutorialRegGroup - , sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybeDateTimeCell tutorialRegisterFrom - , sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybeDateTimeCell tutorialRegisterTo - , sortable (Just "deregister-until") (i18nCell MsgTutorialDeregisterUntil) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybeDateTimeCell tutorialDeregisterUntil - , sortable Nothing mempty $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> cell $ do - linkButton mempty [whamlet|_{MsgTutorialEdit}|] [BCIsButton] . SomeRoute $ CTutorialR tid ssh csh tutorialName TEditR - linkButton mempty [whamlet|_{MsgTutorialDelete}|] [BCIsButton, BCDanger] . SomeRoute $ CTutorialR tid ssh csh tutorialName TDeleteR - ] - dbtSorting = Map.fromList - [ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType ) - , ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName ) - , ("participants", SortColumn $ \tutorial -> E.sub_select . E.from $ \tutorialParticipant -> do - E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId - return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int)) - ) - , ("capacity", SortColumn $ \tutorial -> tutorial E.^. TutorialCapacity ) - , ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom ) - , ("register-group", SortColumn $ \tutorial -> tutorial E.^. TutorialRegGroup ) - , ("register-from", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterFrom ) - , ("register-to", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterTo ) - , ("deregister-until", SortColumn $ \tutorial -> tutorial E.^. TutorialDeregisterUntil ) - ] - dbtFilter = Map.empty - dbtFilterUI = const mempty - dbtStyle = def - dbtParams = def - dbtIdent :: Text - dbtIdent = "tutorials" - dbtCsvEncode = noCsvEncode - dbtCsvDecode = Nothing - - tutorialDBTableValidator = def - & defaultSorting [SortAscBy "type", SortAscBy "name"] - ((), tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable - - siteLayoutMsg (prependCourseTitle tid ssh csh MsgTutorialsHeading) $ do - setTitleI $ prependCourseTitle tid ssh csh MsgTutorialsHeading - $(widgetFile "tutorial-list") - -postTRegisterR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler () -postTRegisterR tid ssh csh tutn = do - uid <- requireAuthId - - Entity tutid Tutorial{..} <- runDB $ fetchTutorial tid ssh csh tutn - - ((btnResult, _), _) <- runFormPost buttonForm - - formResult btnResult $ \case - BtnRegister -> do - runDB . void . insert $ TutorialParticipant tutid uid - addMessageI Success $ MsgTutorialRegisteredSuccess tutorialName - redirect $ CourseR tid ssh csh CShowR - BtnDeregister -> do - runDB . deleteBy $ UniqueTutorialParticipant tutid uid - addMessageI Success $ MsgTutorialDeregisteredSuccess tutorialName - redirect $ CourseR tid ssh csh CShowR - - invalidArgs ["Register/Deregister button required"] - -getTDeleteR, postTDeleteR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html -getTDeleteR = postTDeleteR -postTDeleteR tid ssh csh tutn = do - tutid <- runDB $ fetchTutorialId tid ssh csh tutn - deleteR DeleteRoute - { drRecords = Set.singleton tutid - , drUnjoin = \(_ `E.InnerJoin` tutorial) -> tutorial - , drGetInfo = \(course `E.InnerJoin` tutorial) -> do - E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse - let participants = E.sub_select . E.from $ \participant -> do - E.where_ $ participant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId - return E.countRows - return (course, tutorial, participants :: E.SqlExpr (E.Value Int)) - , drRenderRecord = \(Entity _ Course{..}, Entity _ Tutorial{..}, E.Value ps) -> - return [whamlet|_{prependCourseTitle courseTerm courseSchool courseShorthand (CI.original tutorialName)} (_{MsgParticipantsN ps})|] - , drRecordConfirmString = \(Entity _ Course{..}, Entity _ Tutorial{..}, E.Value ps) -> - return [st|#{termToText (unTermKey courseTerm)}/#{unSchoolKey courseSchool}/#{courseShorthand}/#{tutorialName}+#{tshow ps}|] - , drCaption = SomeMessage MsgTutorialDeleteQuestion - , drSuccessMessage = SomeMessage MsgTutorialDeleted - , drAbort = SomeRoute $ CTutorialR tid ssh csh tutn TUsersR - , drSuccess = SomeRoute $ CourseR tid ssh csh CTutorialListR - , drDelete = \_ -> id -- TODO: audit - } - -getTCommR, postTCommR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html -getTCommR = postTCommR -postTCommR tid ssh csh tutn = do - jSender <- requireAuthId - (cid, tutid) <- runDB $ fetchCourseIdTutorialId tid ssh csh tutn - - commR CommunicationRoute - { crHeading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommTutorialHeading - , crUltDest = SomeRoute $ CTutorialR tid ssh csh tutn TCommR - , crJobs = \Communication{..} -> do - let jSubject = cSubject - jMailContent = cBody - jCourse = cid - allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients - jMailObjectUUID <- liftIO getRandom - jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case - Left email -> return . Address Nothing $ CI.original email - Right rid -> userAddress <$> getJust rid - forM_ allRecipients $ \jRecipientEmail -> - yield JobSendCourseCommunication{..} - , crRecipients = Map.fromList - [ ( RGTutorialParticipants - , E.from $ \(user `E.InnerJoin` participant) -> do - E.on $ user E.^. UserId E.==. participant E.^. TutorialParticipantUser - E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid - return user - ) - , ( RGCourseLecturers - , E.from $ \(user `E.InnerJoin` lecturer) -> do - E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser - E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid - return user - ) - , ( RGCourseCorrectors - , E.from $ \user -> do - E.where_ $ E.exists $ E.from $ \(sheet `E.InnerJoin` corrector) -> do - E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet - E.where_ $ sheet E.^. SheetCourse E.==. E.val cid - E.&&. corrector E.^. SheetCorrectorUser E.==. user E.^. UserId - return user - ) - , ( RGCourseTutors - , E.from $ \user -> do - E.where_ $ E.exists $ E.from $ \(tutorial `E.InnerJoin` tutor) -> do - E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial - E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid - E.&&. tutor E.^. TutorUser E.==. user E.^. UserId - return user - ) - ] - , crRecipientAuth = Just $ \uid -> do - isTutorialUser <- E.selectExists . E.from $ \tutorialUser -> - E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val uid - E.&&. tutorialUser E.^. TutorialParticipantTutorial E.==. E.val tutid - - isAssociatedCorrector <- evalAccessForDB (Just uid) (CourseR tid ssh csh CNotesR) False - isAssociatedTutor <- evalAccessForDB (Just uid) (CourseR tid ssh csh CTutorialListR) False - - mr <- getMsgRenderer - return $ if - | isTutorialUser -> Authorized - | otherwise -> orAR mr isAssociatedCorrector isAssociatedTutor - } - - -instance IsInvitableJunction Tutor where - type InvitationFor Tutor = Tutorial - data InvitableJunction Tutor = JunctionTutor - deriving (Eq, Ord, Read, Show, Generic, Typeable) - data InvitationDBData Tutor = InvDBDataTutor - deriving (Eq, Ord, Read, Show, Generic, Typeable) - data InvitationTokenData Tutor = InvTokenDataTutor - deriving (Eq, Ord, Read, Show, Generic, Typeable) - - _InvitableJunction = iso - (\Tutor{..} -> (tutorUser, tutorTutorial, JunctionTutor)) - (\(tutorUser, tutorTutorial, JunctionTutor) -> Tutor{..}) - -instance ToJSON (InvitableJunction Tutor) where - toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } - toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } -instance FromJSON (InvitableJunction Tutor) where - parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } - -instance ToJSON (InvitationDBData Tutor) where - toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } - toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } -instance FromJSON (InvitationDBData Tutor) where - parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } - -instance ToJSON (InvitationTokenData Tutor) where - toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } - toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 } -instance FromJSON (InvitationTokenData Tutor) where - parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } - -tutorInvitationConfig :: InvitationConfig Tutor -tutorInvitationConfig = InvitationConfig{..} - where - invitationRoute (Entity _ Tutorial{..}) _ = do - Course{..} <- get404 tutorialCourse - return $ CTutorialR courseTerm courseSchool courseShorthand tutorialName TInviteR - invitationResolveFor _ = do - cRoute <- getCurrentRoute - case cRoute of - Just (CTutorialR tid csh ssh tutn TInviteR) -> - fetchTutorialId tid csh ssh tutn - _other -> - error "tutorInvitationConfig called from unsupported route" - invitationSubject (Entity _ Tutorial{..}) _ = do - Course{..} <- get404 tutorialCourse - return . SomeMessage $ MsgMailSubjectTutorInvitation courseTerm courseSchool courseShorthand tutorialName - invitationHeading (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName - invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|] - invitationTokenConfig _ _ = do - itAuthority <- liftHandler requireAuthId - return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing - invitationRestriction _ _ = return Authorized - invitationForm _ _ _ = pure (JunctionTutor, ()) - invitationInsertHook _ _ _ _ = id - invitationSuccessMsg (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName - invitationUltDest (Entity _ Tutorial{..}) _ = do - Course{..} <- get404 tutorialCourse - return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CTutorialListR - -getTInviteR, postTInviteR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html -getTInviteR = postTInviteR -postTInviteR = invitationR tutorInvitationConfig - - -data TutorialForm = TutorialForm - { tfName :: TutorialName - , tfType :: CI Text - , tfCapacity :: Maybe Int - , tfRoom :: Text - , tfTime :: Occurrences - , tfRegGroup :: Maybe (CI Text) - , tfRegisterFrom :: Maybe UTCTime - , tfRegisterTo :: Maybe UTCTime - , tfDeregisterUntil :: Maybe UTCTime - , tfTutors :: Set (Either UserEmail UserId) - } - -tutorialForm :: CourseId -> Maybe TutorialForm -> Form TutorialForm -tutorialForm cid template html = do - MsgRenderer mr <- getMsgRenderer - cRoute <- fromMaybe (error "tutorialForm called from 404-Handler") <$> getCurrentRoute - uid <- liftHandler requireAuthId - - let - tutorForm = Set.fromList <$> massInputAccumA miAdd' miCell' (\p -> Just . SomeRoute $ cRoute :#: p) miLayout' ("tutors" :: Text) (fslI MsgTutorialTutors & setTooltip MsgMassInputTip) True (Set.toList . tfTutors <$> template) - where - miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId]) - miAdd' nudge submitView csrf = do - (addRes, addView) <- mpreq (multiUserField False . Just $ tutUserSuggestions uid) ("" & addName (nudge "email")) Nothing - let - addRes' - | otherwise - = addRes <&> \newDat oldDat -> if - | existing <- newDat `Set.intersection` Set.fromList oldDat - , not $ Set.null existing - -> FormFailure [mr MsgTutorialTutorAlreadyAdded] - | otherwise - -> FormSuccess $ Set.toList newDat - return (addRes', $(widgetFile "tutorial/tutorMassInput/add")) - - - miCell' :: Either UserEmail UserId -> Widget - miCell' (Left email) = - $(widgetFile "tutorial/tutorMassInput/cellInvitation") - miCell' (Right userId) = do - User{..} <- liftHandler . runDB $ get404 userId - $(widgetFile "tutorial/tutorMassInput/cellKnown") - - miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) () - miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "tutorial/tutorMassInput/layout") - - flip (renderAForm FormStandard) html $ TutorialForm - <$> areq (textField & cfStrip & cfCI) (fslpI MsgTutorialName (mr MsgTutorialName) & setTooltip MsgTutorialNameTip) (tfName <$> template) - <*> areq (textField & cfStrip & cfCI & addDatalist tutTypeDatalist) (fslpI MsgTutorialType $ mr MsgTutorialType) (tfType <$> template) - <*> aopt (natFieldI MsgTutorialCapacityNonPositive) (fslpI MsgTutorialCapacity (mr MsgTutorialCapacity) & setTooltip MsgTutorialCapacityTip) (tfCapacity <$> template) - <*> areq textField (fslpI MsgTutorialRoom $ mr MsgTutorialRoomPlaceholder) (tfRoom <$> template) - <*> occurrencesAForm ("occurrences" :: Text) (tfTime <$> template) - <*> aopt (textField & cfStrip & cfCI) (fslI MsgTutorialRegGroup & setTooltip MsgTutorialRegGroupTip) ((tfRegGroup <$> template) <|> Just (Just "tutorial")) - <*> aopt utcTimeField (fslpI MsgRegisterFrom (mr MsgDate) - & setTooltip MsgCourseRegisterFromTip - ) (tfRegisterFrom <$> template) - <*> aopt utcTimeField (fslpI MsgRegisterTo (mr MsgDate) - & setTooltip MsgCourseRegisterToTip - ) (tfRegisterTo <$> template) - <*> aopt utcTimeField (fslpI MsgDeRegUntil (mr MsgDate) - & setTooltip MsgCourseDeregisterUntilTip - ) (tfDeregisterUntil <$> template) - <*> tutorForm - where - tutTypeDatalist :: HandlerFor UniWorX (OptionList (CI Text)) - tutTypeDatalist = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $ - fmap (setOf $ folded . _Value) . E.select . E.from $ \tutorial -> do - E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid - return $ tutorial E.^. TutorialType - - tutUserSuggestions :: UserId -> E.SqlQuery (E.SqlExpr (Entity User)) - tutUserSuggestions uid = E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` tutorial `E.InnerJoin` tutor `E.InnerJoin` tutorUser) -> do - E.on $ tutorUser E.^. UserId E.==. tutor E.^. TutorUser - E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId - E.on $ tutorial E.^. TutorialCourse E.==. course E.^. CourseId - E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse - E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid - return tutorUser - - -getCTutorialNewR, postCTutorialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getCTutorialNewR = postCTutorialNewR -postCTutorialNewR tid ssh csh = do - Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh - - ((newTutResult, newTutWidget), newTutEnctype) <- runFormPost $ tutorialForm cid Nothing - - formResult newTutResult $ \TutorialForm{..} -> do - insertRes <- runDBJobs $ do - now <- liftIO getCurrentTime - insertRes <- insertUnique Tutorial - { tutorialName = tfName - , tutorialCourse = cid - , tutorialType = tfType - , tutorialCapacity = tfCapacity - , tutorialRoom = tfRoom - , tutorialTime = tfTime - , tutorialRegGroup = tfRegGroup - , tutorialRegisterFrom = tfRegisterFrom - , tutorialRegisterTo = tfRegisterTo - , tutorialDeregisterUntil = tfDeregisterUntil - , tutorialLastChanged = now - } - whenIsJust insertRes $ \tutid -> do - let (invites, adds) = partitionEithers $ Set.toList tfTutors - insertMany_ $ map (Tutor tutid) adds - sinkInvitationsF tutorInvitationConfig $ map (, tutid, (InvDBDataTutor, InvTokenDataTutor)) invites - return insertRes - case insertRes of - Nothing -> addMessageI Error $ MsgTutorialNameTaken tfName - Just _ -> do - addMessageI Success $ MsgTutorialCreated tfName - redirect $ CourseR tid ssh csh CTutorialListR - - let heading = prependCourseTitle tid ssh csh MsgTutorialNew - - siteLayoutMsg heading $ do - setTitleI heading - let - newTutForm = wrapForm newTutWidget def - { formMethod = POST - , formAction = Just . SomeRoute $ CourseR tid ssh csh CTutorialNewR - , formEncoding = newTutEnctype - } - $(widgetFile "tutorial-new") - -getTEditR, postTEditR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html -getTEditR = postTEditR -postTEditR tid ssh csh tutn = do - (cid, tutid, template) <- runDB $ do - (cid, Entity tutid Tutorial{..}) <- fetchCourseIdTutorial tid ssh csh tutn - - tutorIds <- fmap (map E.unValue) . E.select . E.from $ \tutor -> do - E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid - return $ tutor E.^. TutorUser - - tutorInvites <- sourceInvitationsF @Tutor tutid - - let - template = TutorialForm - { tfName = tutorialName - , tfType = tutorialType - , tfCapacity = tutorialCapacity - , tfRoom = tutorialRoom - , tfTime = tutorialTime - , tfRegGroup = tutorialRegGroup - , tfRegisterFrom = tutorialRegisterFrom - , tfRegisterTo = tutorialRegisterTo - , tfDeregisterUntil = tutorialDeregisterUntil - , tfTutors = Set.fromList (map Right tutorIds) - <> Set.mapMonotonic Left (Map.keysSet tutorInvites) - } - - return (cid, tutid, template) - - ((newTutResult, newTutWidget), newTutEnctype) <- runFormPost . tutorialForm cid $ Just template - - formResult newTutResult $ \TutorialForm{..} -> do - insertRes <- runDBJobs $ do - now <- liftIO getCurrentTime - insertRes <- myReplaceUnique tutid Tutorial - { tutorialName = tfName - , tutorialCourse = cid - , tutorialType = tfType - , tutorialCapacity = tfCapacity - , tutorialRoom = tfRoom - , tutorialTime = tfTime - , tutorialRegGroup = tfRegGroup - , tutorialRegisterFrom = tfRegisterFrom - , tutorialRegisterTo = tfRegisterTo - , tutorialDeregisterUntil = tfDeregisterUntil - , tutorialLastChanged = now - } - when (is _Nothing insertRes) $ do - let (invites, adds) = partitionEithers $ Set.toList tfTutors - - deleteWhere [ TutorTutorial ==. tutid ] - insertMany_ $ map (Tutor tutid) adds - - deleteWhere [ InvitationFor ==. invRef @Tutor tutid, InvitationEmail /<-. invites ] - sinkInvitationsF tutorInvitationConfig $ map (, tutid, (InvDBDataTutor, InvTokenDataTutor)) invites - return insertRes - case insertRes of - Just _ -> addMessageI Error $ MsgTutorialNameTaken tfName - Nothing -> do - addMessageI Success $ MsgTutorialEdited tfName - redirect $ CourseR tid ssh csh CTutorialListR - - let heading = prependCourseTitle tid ssh csh . MsgTutorialEditHeading $ tfName template - - siteLayoutMsg heading $ do - setTitleI heading - let - newTutForm = wrapForm newTutWidget def - { formMethod = POST - , formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutn TEditR - , formEncoding = newTutEnctype - } - $(widgetFile "tutorial-edit") +import Handler.Tutorial.Communication as Handler.Tutorial +import Handler.Tutorial.Delete as Handler.Tutorial +import Handler.Tutorial.Edit as Handler.Tutorial +import Handler.Tutorial.Form as Handler.Tutorial +import Handler.Tutorial.List as Handler.Tutorial +import Handler.Tutorial.New as Handler.Tutorial +import Handler.Tutorial.Register as Handler.Tutorial +import Handler.Tutorial.TutorInvite as Handler.Tutorial +import Handler.Tutorial.Users as Handler.Tutorial diff --git a/src/Handler/Tutorial/Communication.hs b/src/Handler/Tutorial/Communication.hs new file mode 100644 index 000000000..6257caeb1 --- /dev/null +++ b/src/Handler/Tutorial/Communication.hs @@ -0,0 +1,81 @@ +module Handler.Tutorial.Communication + ( getTCommR, postTCommR + ) where + +import Import +import Handler.Utils +import Handler.Utils.Tutorial +import Handler.Utils.Communication + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E + +import qualified Data.Map as Map +import qualified Data.Set as Set + +import qualified Data.CaseInsensitive as CI + + +getTCommR, postTCommR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html +getTCommR = postTCommR +postTCommR tid ssh csh tutn = do + jSender <- requireAuthId + (cid, tutid) <- runDB $ fetchCourseIdTutorialId tid ssh csh tutn + + commR CommunicationRoute + { crHeading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommTutorialHeading + , crUltDest = SomeRoute $ CTutorialR tid ssh csh tutn TCommR + , crJobs = \Communication{..} -> do + let jSubject = cSubject + jMailContent = cBody + jCourse = cid + allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients + jMailObjectUUID <- liftIO getRandom + jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case + Left email -> return . Address Nothing $ CI.original email + Right rid -> userAddress <$> getJust rid + forM_ allRecipients $ \jRecipientEmail -> + yield JobSendCourseCommunication{..} + , crRecipients = Map.fromList + [ ( RGTutorialParticipants + , E.from $ \(user `E.InnerJoin` participant) -> do + E.on $ user E.^. UserId E.==. participant E.^. TutorialParticipantUser + E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid + return user + ) + , ( RGCourseLecturers + , E.from $ \(user `E.InnerJoin` lecturer) -> do + E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser + E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid + return user + ) + , ( RGCourseCorrectors + , E.from $ \user -> do + E.where_ $ E.exists $ E.from $ \(sheet `E.InnerJoin` corrector) -> do + E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet + E.where_ $ sheet E.^. SheetCourse E.==. E.val cid + E.&&. corrector E.^. SheetCorrectorUser E.==. user E.^. UserId + return user + ) + , ( RGCourseTutors + , E.from $ \user -> do + E.where_ $ E.exists $ E.from $ \(tutorial `E.InnerJoin` tutor) -> do + E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial + E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid + E.&&. tutor E.^. TutorUser E.==. user E.^. UserId + return user + ) + ] + , crRecipientAuth = Just $ \uid -> do + isTutorialUser <- E.selectExists . E.from $ \tutorialUser -> + E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val uid + E.&&. tutorialUser E.^. TutorialParticipantTutorial E.==. E.val tutid + + isAssociatedCorrector <- evalAccessForDB (Just uid) (CourseR tid ssh csh CNotesR) False + isAssociatedTutor <- evalAccessForDB (Just uid) (CourseR tid ssh csh CTutorialListR) False + + mr <- getMsgRenderer + return $ if + | isTutorialUser -> Authorized + | otherwise -> orAR mr isAssociatedCorrector isAssociatedTutor + } diff --git a/src/Handler/Tutorial/Delete.hs b/src/Handler/Tutorial/Delete.hs new file mode 100644 index 000000000..b70fed01c --- /dev/null +++ b/src/Handler/Tutorial/Delete.hs @@ -0,0 +1,39 @@ +module Handler.Tutorial.Delete + ( getTDeleteR, postTDeleteR + ) where + +import Import +import Handler.Utils +import Handler.Utils.Tutorial +import Handler.Utils.Delete + +import qualified Database.Esqueleto as E + +import qualified Data.Set as Set + +import qualified Data.CaseInsensitive as CI + + +getTDeleteR, postTDeleteR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html +getTDeleteR = postTDeleteR +postTDeleteR tid ssh csh tutn = do + tutid <- runDB $ fetchTutorialId tid ssh csh tutn + deleteR DeleteRoute + { drRecords = Set.singleton tutid + , drUnjoin = \(_ `E.InnerJoin` tutorial) -> tutorial + , drGetInfo = \(course `E.InnerJoin` tutorial) -> do + E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse + let participants = E.sub_select . E.from $ \participant -> do + E.where_ $ participant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId + return E.countRows + return (course, tutorial, participants :: E.SqlExpr (E.Value Int)) + , drRenderRecord = \(Entity _ Course{..}, Entity _ Tutorial{..}, E.Value ps) -> + return [whamlet|_{prependCourseTitle courseTerm courseSchool courseShorthand (CI.original tutorialName)} (_{MsgParticipantsN ps})|] + , drRecordConfirmString = \(Entity _ Course{..}, Entity _ Tutorial{..}, E.Value ps) -> + return [st|#{termToText (unTermKey courseTerm)}/#{unSchoolKey courseSchool}/#{courseShorthand}/#{tutorialName}+#{tshow ps}|] + , drCaption = SomeMessage MsgTutorialDeleteQuestion + , drSuccessMessage = SomeMessage MsgTutorialDeleted + , drAbort = SomeRoute $ CTutorialR tid ssh csh tutn TUsersR + , drSuccess = SomeRoute $ CourseR tid ssh csh CTutorialListR + , drDelete = const id -- TODO: audit + } diff --git a/src/Handler/Tutorial/Edit.hs b/src/Handler/Tutorial/Edit.hs new file mode 100644 index 000000000..49390de5f --- /dev/null +++ b/src/Handler/Tutorial/Edit.hs @@ -0,0 +1,92 @@ +module Handler.Tutorial.Edit + ( getTEditR, postTEditR + ) where + +import Import +import Handler.Utils +import Handler.Utils.Tutorial +import Handler.Utils.Invitations +import Jobs.Queue + +import qualified Database.Esqueleto as E + +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Handler.Tutorial.Form +import Handler.Tutorial.TutorInvite + + +getTEditR, postTEditR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html +getTEditR = postTEditR +postTEditR tid ssh csh tutn = do + (cid, tutid, template) <- runDB $ do + (cid, Entity tutid Tutorial{..}) <- fetchCourseIdTutorial tid ssh csh tutn + + tutorIds <- fmap (map E.unValue) . E.select . E.from $ \tutor -> do + E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid + return $ tutor E.^. TutorUser + + tutorInvites <- sourceInvitationsF @Tutor tutid + + let + template = TutorialForm + { tfName = tutorialName + , tfType = tutorialType + , tfCapacity = tutorialCapacity + , tfRoom = tutorialRoom + , tfTime = tutorialTime + , tfRegGroup = tutorialRegGroup + , tfRegisterFrom = tutorialRegisterFrom + , tfRegisterTo = tutorialRegisterTo + , tfDeregisterUntil = tutorialDeregisterUntil + , tfTutors = Set.fromList (map Right tutorIds) + <> Set.mapMonotonic Left (Map.keysSet tutorInvites) + } + + return (cid, tutid, template) + + ((newTutResult, newTutWidget), newTutEnctype) <- runFormPost . tutorialForm cid $ Just template + + formResult newTutResult $ \TutorialForm{..} -> do + insertRes <- runDBJobs $ do + now <- liftIO getCurrentTime + insertRes <- myReplaceUnique tutid Tutorial + { tutorialName = tfName + , tutorialCourse = cid + , tutorialType = tfType + , tutorialCapacity = tfCapacity + , tutorialRoom = tfRoom + , tutorialTime = tfTime + , tutorialRegGroup = tfRegGroup + , tutorialRegisterFrom = tfRegisterFrom + , tutorialRegisterTo = tfRegisterTo + , tutorialDeregisterUntil = tfDeregisterUntil + , tutorialLastChanged = now + } + when (is _Nothing insertRes) $ do + let (invites, adds) = partitionEithers $ Set.toList tfTutors + + deleteWhere [ TutorTutorial ==. tutid ] + insertMany_ $ map (Tutor tutid) adds + + deleteWhere [ InvitationFor ==. invRef @Tutor tutid, InvitationEmail /<-. invites ] + sinkInvitationsF tutorInvitationConfig $ map (, tutid, (InvDBDataTutor, InvTokenDataTutor)) invites + return insertRes + case insertRes of + Just _ -> addMessageI Error $ MsgTutorialNameTaken tfName + Nothing -> do + addMessageI Success $ MsgTutorialEdited tfName + redirect $ CourseR tid ssh csh CTutorialListR + + let heading = prependCourseTitle tid ssh csh . MsgTutorialEditHeading $ tfName template + + siteLayoutMsg heading $ do + setTitleI heading + let + newTutForm = wrapForm newTutWidget def + { formMethod = POST + , formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutn TEditR + , formEncoding = newTutEnctype + } + $(widgetFile "tutorial-edit") diff --git a/src/Handler/Tutorial/Form.hs b/src/Handler/Tutorial/Form.hs new file mode 100644 index 000000000..2f1aa6ccf --- /dev/null +++ b/src/Handler/Tutorial/Form.hs @@ -0,0 +1,96 @@ +module Handler.Tutorial.Form + ( TutorialForm(..) + , tutorialForm + ) where + +import Import +import Handler.Utils +import Handler.Utils.Form.Occurrences + +import qualified Database.Esqueleto as E + +import Data.Map ((!)) +import qualified Data.Set as Set + +import qualified Data.CaseInsensitive as CI + + +data TutorialForm = TutorialForm + { tfName :: TutorialName + , tfType :: CI Text + , tfCapacity :: Maybe Int + , tfRoom :: Text + , tfTime :: Occurrences + , tfRegGroup :: Maybe (CI Text) + , tfRegisterFrom :: Maybe UTCTime + , tfRegisterTo :: Maybe UTCTime + , tfDeregisterUntil :: Maybe UTCTime + , tfTutors :: Set (Either UserEmail UserId) + } + +tutorialForm :: CourseId -> Maybe TutorialForm -> Form TutorialForm +tutorialForm cid template html = do + MsgRenderer mr <- getMsgRenderer + cRoute <- fromMaybe (error "tutorialForm called from 404-Handler") <$> getCurrentRoute + uid <- liftHandler requireAuthId + + let + tutorForm = Set.fromList <$> massInputAccumA miAdd' miCell' (\p -> Just . SomeRoute $ cRoute :#: p) miLayout' ("tutors" :: Text) (fslI MsgTutorialTutors & setTooltip MsgMassInputTip) True (Set.toList . tfTutors <$> template) + where + miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId]) + miAdd' nudge submitView csrf = do + (addRes, addView) <- mpreq (multiUserField False . Just $ tutUserSuggestions uid) ("" & addName (nudge "email")) Nothing + let + addRes' + | otherwise + = addRes <&> \newDat oldDat -> if + | existing <- newDat `Set.intersection` Set.fromList oldDat + , not $ Set.null existing + -> FormFailure [mr MsgTutorialTutorAlreadyAdded] + | otherwise + -> FormSuccess $ Set.toList newDat + return (addRes', $(widgetFile "tutorial/tutorMassInput/add")) + + + miCell' :: Either UserEmail UserId -> Widget + miCell' (Left email) = + $(widgetFile "tutorial/tutorMassInput/cellInvitation") + miCell' (Right userId) = do + User{..} <- liftHandler . runDB $ get404 userId + $(widgetFile "tutorial/tutorMassInput/cellKnown") + + miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) () + miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "tutorial/tutorMassInput/layout") + + flip (renderAForm FormStandard) html $ TutorialForm + <$> areq (textField & cfStrip & cfCI) (fslpI MsgTutorialName (mr MsgTutorialName) & setTooltip MsgTutorialNameTip) (tfName <$> template) + <*> areq (textField & cfStrip & cfCI & addDatalist tutTypeDatalist) (fslpI MsgTutorialType $ mr MsgTutorialType) (tfType <$> template) + <*> aopt (natFieldI MsgTutorialCapacityNonPositive) (fslpI MsgTutorialCapacity (mr MsgTutorialCapacity) & setTooltip MsgTutorialCapacityTip) (tfCapacity <$> template) + <*> areq textField (fslpI MsgTutorialRoom $ mr MsgTutorialRoomPlaceholder) (tfRoom <$> template) + <*> occurrencesAForm ("occurrences" :: Text) (tfTime <$> template) + <*> aopt (textField & cfStrip & cfCI) (fslI MsgTutorialRegGroup & setTooltip MsgTutorialRegGroupTip) ((tfRegGroup <$> template) <|> Just (Just "tutorial")) + <*> aopt utcTimeField (fslpI MsgRegisterFrom (mr MsgDate) + & setTooltip MsgCourseRegisterFromTip + ) (tfRegisterFrom <$> template) + <*> aopt utcTimeField (fslpI MsgRegisterTo (mr MsgDate) + & setTooltip MsgCourseRegisterToTip + ) (tfRegisterTo <$> template) + <*> aopt utcTimeField (fslpI MsgDeRegUntil (mr MsgDate) + & setTooltip MsgCourseDeregisterUntilTip + ) (tfDeregisterUntil <$> template) + <*> tutorForm + where + tutTypeDatalist :: HandlerFor UniWorX (OptionList (CI Text)) + tutTypeDatalist = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $ + fmap (setOf $ folded . _Value) . E.select . E.from $ \tutorial -> do + E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid + return $ tutorial E.^. TutorialType + + tutUserSuggestions :: UserId -> E.SqlQuery (E.SqlExpr (Entity User)) + tutUserSuggestions uid = E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` tutorial `E.InnerJoin` tutor `E.InnerJoin` tutorUser) -> do + E.on $ tutorUser E.^. UserId E.==. tutor E.^. TutorUser + E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId + E.on $ tutorial E.^. TutorialCourse E.==. course E.^. CourseId + E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse + E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid + return tutorUser diff --git a/src/Handler/Tutorial/List.hs b/src/Handler/Tutorial/List.hs new file mode 100644 index 000000000..ee6756113 --- /dev/null +++ b/src/Handler/Tutorial/List.hs @@ -0,0 +1,87 @@ +module Handler.Tutorial.List + ( getCTutorialListR + ) where + +import Import +import Handler.Utils + +import qualified Database.Esqueleto as E +import Database.Esqueleto.Utils.TH + +import qualified Data.Map as Map + +import qualified Data.CaseInsensitive as CI + + +getCTutorialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCTutorialListR tid ssh csh = do + Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh + + let + tutorialDBTable = DBTable{..} + where + dbtSQLQuery tutorial = do + E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid + let participants = E.sub_select . E.from $ \tutorialParticipant -> do + E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId + return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int)) + return (tutorial, participants) + dbtRowKey = (E.^. TutorialId) + dbtProj = return . over (_dbrOutput . _2) E.unValue + dbtColonnade = dbColonnade $ mconcat + [ sortable (Just "type") (i18nCell MsgTutorialType) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell $ CI.original tutorialType + , sortable (Just "name") (i18nCell MsgTutorialName) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|] + , sortable Nothing (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = (Entity tutid _, _) } -> sqlCell $ do + tutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do + E.on $ tutor E.^. TutorUser E.==. user E.^. UserId + E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid + return (user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname) + return [whamlet| + $newline never +
              + $forall tutor <- tutors +
            • + ^{nameEmailWidget' tutor} + |] + , sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, n) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) $ tshow n + , sortable (Just "capacity") (i18nCell MsgTutorialCapacity) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . tshow) tutorialCapacity + , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell tutorialRoom + , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> occurrencesCell tutorialTime + , sortable (Just "register-group") (i18nCell MsgTutorialRegGroup) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . CI.original) tutorialRegGroup + , sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybeDateTimeCell tutorialRegisterFrom + , sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybeDateTimeCell tutorialRegisterTo + , sortable (Just "deregister-until") (i18nCell MsgTutorialDeregisterUntil) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybeDateTimeCell tutorialDeregisterUntil + , sortable Nothing mempty $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> cell $ do + linkButton mempty [whamlet|_{MsgTutorialEdit}|] [BCIsButton] . SomeRoute $ CTutorialR tid ssh csh tutorialName TEditR + linkButton mempty [whamlet|_{MsgTutorialDelete}|] [BCIsButton, BCDanger] . SomeRoute $ CTutorialR tid ssh csh tutorialName TDeleteR + ] + dbtSorting = Map.fromList + [ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType ) + , ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName ) + , ("participants", SortColumn $ \tutorial -> E.sub_select . E.from $ \tutorialParticipant -> do + E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId + return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int)) + ) + , ("capacity", SortColumn $ \tutorial -> tutorial E.^. TutorialCapacity ) + , ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom ) + , ("register-group", SortColumn $ \tutorial -> tutorial E.^. TutorialRegGroup ) + , ("register-from", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterFrom ) + , ("register-to", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterTo ) + , ("deregister-until", SortColumn $ \tutorial -> tutorial E.^. TutorialDeregisterUntil ) + ] + dbtFilter = Map.empty + dbtFilterUI = const mempty + dbtStyle = def + dbtParams = def + dbtIdent :: Text + dbtIdent = "tutorials" + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + + tutorialDBTableValidator = def + & defaultSorting [SortAscBy "type", SortAscBy "name"] + ((), tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable + + siteLayoutMsg (prependCourseTitle tid ssh csh MsgTutorialsHeading) $ do + setTitleI $ prependCourseTitle tid ssh csh MsgTutorialsHeading + $(widgetFile "tutorial-list") diff --git a/src/Handler/Tutorial/New.hs b/src/Handler/Tutorial/New.hs new file mode 100644 index 000000000..6e1fd03f0 --- /dev/null +++ b/src/Handler/Tutorial/New.hs @@ -0,0 +1,60 @@ +module Handler.Tutorial.New + ( getCTutorialNewR, postCTutorialNewR + ) where + +import Import +import Handler.Utils +import Handler.Utils.Invitations +import Jobs.Queue + +import qualified Data.Set as Set + +import Handler.Tutorial.Form +import Handler.Tutorial.TutorInvite + + +getCTutorialNewR, postCTutorialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCTutorialNewR = postCTutorialNewR +postCTutorialNewR tid ssh csh = do + Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh + + ((newTutResult, newTutWidget), newTutEnctype) <- runFormPost $ tutorialForm cid Nothing + + formResult newTutResult $ \TutorialForm{..} -> do + insertRes <- runDBJobs $ do + now <- liftIO getCurrentTime + insertRes <- insertUnique Tutorial + { tutorialName = tfName + , tutorialCourse = cid + , tutorialType = tfType + , tutorialCapacity = tfCapacity + , tutorialRoom = tfRoom + , tutorialTime = tfTime + , tutorialRegGroup = tfRegGroup + , tutorialRegisterFrom = tfRegisterFrom + , tutorialRegisterTo = tfRegisterTo + , tutorialDeregisterUntil = tfDeregisterUntil + , tutorialLastChanged = now + } + whenIsJust insertRes $ \tutid -> do + let (invites, adds) = partitionEithers $ Set.toList tfTutors + insertMany_ $ map (Tutor tutid) adds + sinkInvitationsF tutorInvitationConfig $ map (, tutid, (InvDBDataTutor, InvTokenDataTutor)) invites + return insertRes + case insertRes of + Nothing -> addMessageI Error $ MsgTutorialNameTaken tfName + Just _ -> do + addMessageI Success $ MsgTutorialCreated tfName + redirect $ CourseR tid ssh csh CTutorialListR + + let heading = prependCourseTitle tid ssh csh MsgTutorialNew + + siteLayoutMsg heading $ do + setTitleI heading + let + newTutForm = wrapForm newTutWidget def + { formMethod = POST + , formAction = Just . SomeRoute $ CourseR tid ssh csh CTutorialNewR + , formEncoding = newTutEnctype + } + $(widgetFile "tutorial-new") diff --git a/src/Handler/Tutorial/Register.hs b/src/Handler/Tutorial/Register.hs new file mode 100644 index 000000000..44e35114c --- /dev/null +++ b/src/Handler/Tutorial/Register.hs @@ -0,0 +1,28 @@ +module Handler.Tutorial.Register + ( postTRegisterR + ) where + +import Import +import Handler.Utils +import Handler.Utils.Tutorial + + +postTRegisterR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler () +postTRegisterR tid ssh csh tutn = do + uid <- requireAuthId + + Entity tutid Tutorial{..} <- runDB $ fetchTutorial tid ssh csh tutn + + ((btnResult, _), _) <- runFormPost buttonForm + + formResult btnResult $ \case + BtnRegister -> do + runDB . void . insert $ TutorialParticipant tutid uid + addMessageI Success $ MsgTutorialRegisteredSuccess tutorialName + redirect $ CourseR tid ssh csh CShowR + BtnDeregister -> do + runDB . deleteBy $ UniqueTutorialParticipant tutid uid + addMessageI Success $ MsgTutorialDeregisteredSuccess tutorialName + redirect $ CourseR tid ssh csh CShowR + + invalidArgs ["Register/Deregister button required"] diff --git a/src/Handler/Tutorial/TutorInvite.hs b/src/Handler/Tutorial/TutorInvite.hs new file mode 100644 index 000000000..1c1f119db --- /dev/null +++ b/src/Handler/Tutorial/TutorInvite.hs @@ -0,0 +1,79 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Handler.Tutorial.TutorInvite + ( getTInviteR, postTInviteR + , tutorInvitationConfig + , InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..) + ) where + +import Import +import Handler.Utils.Tutorial +import Handler.Utils.Invitations + +import Data.Aeson hiding (Result(..)) +import Text.Hamlet (ihamlet) + + +instance IsInvitableJunction Tutor where + type InvitationFor Tutor = Tutorial + data InvitableJunction Tutor = JunctionTutor + deriving (Eq, Ord, Read, Show, Generic, Typeable) + data InvitationDBData Tutor = InvDBDataTutor + deriving (Eq, Ord, Read, Show, Generic, Typeable) + data InvitationTokenData Tutor = InvTokenDataTutor + deriving (Eq, Ord, Read, Show, Generic, Typeable) + + _InvitableJunction = iso + (\Tutor{..} -> (tutorUser, tutorTutorial, JunctionTutor)) + (\(tutorUser, tutorTutorial, JunctionTutor) -> Tutor{..}) + +instance ToJSON (InvitableJunction Tutor) where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } +instance FromJSON (InvitableJunction Tutor) where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } + +instance ToJSON (InvitationDBData Tutor) where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } +instance FromJSON (InvitationDBData Tutor) where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } + +instance ToJSON (InvitationTokenData Tutor) where + toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } + toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 } +instance FromJSON (InvitationTokenData Tutor) where + parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } + +tutorInvitationConfig :: InvitationConfig Tutor +tutorInvitationConfig = InvitationConfig{..} + where + invitationRoute (Entity _ Tutorial{..}) _ = do + Course{..} <- get404 tutorialCourse + return $ CTutorialR courseTerm courseSchool courseShorthand tutorialName TInviteR + invitationResolveFor _ = do + cRoute <- getCurrentRoute + case cRoute of + Just (CTutorialR tid csh ssh tutn TInviteR) -> + fetchTutorialId tid csh ssh tutn + _other -> + error "tutorInvitationConfig called from unsupported route" + invitationSubject (Entity _ Tutorial{..}) _ = do + Course{..} <- get404 tutorialCourse + return . SomeMessage $ MsgMailSubjectTutorInvitation courseTerm courseSchool courseShorthand tutorialName + invitationHeading (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName + invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|] + invitationTokenConfig _ _ = do + itAuthority <- liftHandler requireAuthId + return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing + invitationRestriction _ _ = return Authorized + invitationForm _ _ _ = pure (JunctionTutor, ()) + invitationInsertHook _ _ _ _ = id + invitationSuccessMsg (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName + invitationUltDest (Entity _ Tutorial{..}) _ = do + Course{..} <- get404 tutorialCourse + return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CTutorialListR + +getTInviteR, postTInviteR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html +getTInviteR = postTInviteR +postTInviteR = invitationR tutorInvitationConfig From 89adf7f2dc1caa90fc71adbcf0dc04936b685bd3 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 1 Oct 2019 09:07:21 +0200 Subject: [PATCH 36/38] fix(mail): honor userCsvOptions and userDisplayEmail --- messages/uniworx/de.msg | 2 ++ src/Handler/Utils/Mail.hs | 11 ++++++++++- src/Jobs/Handler/Invitation.hs | 2 +- src/Jobs/Handler/SendCourseCommunication.hs | 10 ++++++---- src/Jobs/Handler/SendNotification/SubmissionRated.hs | 2 +- src/Mail.hs | 9 --------- src/Model/Types/Misc.hs | 8 ++++++++ 7 files changed, 28 insertions(+), 16 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 02c290484..730487adc 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1142,6 +1142,8 @@ CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht CommRecipientsList: Die an Sie selbst verschickte Kopie der Nachricht wird, zu Archivierungszwecken, eine vollständige Liste aller Empfänger enthalten. Die Empfängerliste wird im CSV-Format and die E-Mail angehängt. Andere Empfänger erhalten die Liste nicht. Bitte entfernen Sie dementsprechend den Anhang bevor Sie die E-Mail weiterleiten oder anderweitig mit Dritten teilen. CommDuplicateRecipients n@Int: #{n} #{pluralDE n "doppelter" "doppelte"} Empfänger ignoriert CommSuccess n@Int: Nachricht wurde an #{n} Empfänger versandt +CommUndisclosedRecipients: Verborgene Empfänger +CommAllRecipients: alle-empfaenger CommCourseHeading: Kursmitteilung CommTutorialHeading: Tutorium-Mitteilung diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index 726d7c975..814657010 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -1,6 +1,6 @@ module Handler.Utils.Mail ( addRecipientsDB - , userAddress + , userAddress, userAddressFrom , userMailT , addFileDB ) where @@ -28,7 +28,16 @@ addRecipientsDB uFilter = runConduit $ transPipe (liftHandler . runDB) (selectSo let addr = Address (Just userDisplayName) $ CI.original userEmail _mailTo %= flip snoc addr +userAddressFrom :: User -> Address +-- ^ Format an e-mail address suitable for usage in a @From@-header +-- +-- Uses `userDisplayEmail` +userAddressFrom User{userDisplayEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userDisplayEmail + userAddress :: User -> Address +-- ^ Format an e-mail address suitable for usage as a recipient +-- +-- Uses `userEmail` userAddress User{userEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userEmail userMailT :: ( MonadHandler m diff --git a/src/Jobs/Handler/Invitation.hs b/src/Jobs/Handler/Invitation.hs index 08526c0e8..87bab06cf 100644 --- a/src/Jobs/Handler/Invitation.hs +++ b/src/Jobs/Handler/Invitation.hs @@ -20,7 +20,7 @@ dispatchJobInvitation jInviter jInvitee jInvitationUrl jInvitationSubject jInvit whenIsJust mInviter $ \jInviter' -> mailT def $ do _mailTo .= [Address Nothing $ CI.original jInvitee] - replaceMailHeader "Reply-To" . Just . renderAddress $ userAddress jInviter' + replaceMailHeader "Reply-To" . Just . renderAddress $ userAddressFrom jInviter' replaceMailHeader "Auto-Submitted" $ Just "auto-generated" replaceMailHeader "Subject" $ Just jInvitationSubject addPart ($(ihamletFile "templates/mail/invitation.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) diff --git a/src/Jobs/Handler/SendCourseCommunication.hs b/src/Jobs/Handler/SendCourseCommunication.hs index 7a35229d0..0f05d72a1 100644 --- a/src/Jobs/Handler/SendCourseCommunication.hs +++ b/src/Jobs/Handler/SendCourseCommunication.hs @@ -22,13 +22,15 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours <$> getJust jSender <*> getJust jCourse either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do + MsgRenderer mr <- getMailMsgRenderer + void $ setMailObjectUUID jMailObjectUUID - _mailFrom .= userAddress sender - addMailHeader "Cc" "Undisclosed Recipients:;" + _mailFrom .= userAddressFrom sender + addMailHeader "Cc" [st|#{mr MsgCommUndisclosedRecipients}:;|] addMailHeader "Auto-Submitted" "no" setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgCommCourseSubject) SomeMessage jSubject void $ addPart jMailContent when (jRecipientEmail == Right jSender) $ addPart' $ do - partIsAttachment $ "all-recipients" `addExtension` unpack extensionCsv - toMailPart $ toDefaultOrderedCsvRendered jAllRecipientAddresses + partIsAttachment $ unpack (mr MsgCommAllRecipients) `addExtension` unpack extensionCsv + toMailPart (toDefaultOrderedCsvRendered jAllRecipientAddresses, userCsvOptions sender) diff --git a/src/Jobs/Handler/SendNotification/SubmissionRated.hs b/src/Jobs/Handler/SendNotification/SubmissionRated.hs index a4448e1e6..466a9586f 100644 --- a/src/Jobs/Handler/SendNotification/SubmissionRated.hs +++ b/src/Jobs/Handler/SendNotification/SubmissionRated.hs @@ -23,7 +23,7 @@ dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipien return (course, sheet, submission, corrector) whenIsJust corrector $ \corrector' -> - addMailHeader "Reply-To" . renderAddress $ userAddress corrector' + addMailHeader "Reply-To" . renderAddress $ userAddressFrom corrector' replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI $ MsgMailSubjectSubmissionRated courseShorthand diff --git a/src/Mail.hs b/src/Mail.hs index 60baf72b5..53b0e6611 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -74,9 +74,6 @@ import qualified Data.ByteString.Lazy as LBS import Utils (MsgRendererS(..), MonadSecretBox(..), maybeT) import Utils.Lens.TH -import Utils.Csv (CsvRendered(..), typeCsv') -import qualified Data.Csv as Csv - import Control.Lens hiding (from) import Control.Lens.Extras (is) @@ -382,12 +379,6 @@ instance YesodMail site => ToMailPart site Aeson.Value where _partEncoding .= QuotedPrintableText _partContent .= Aeson.encodePretty val -instance YesodMail site => ToMailPart site CsvRendered where - toMailPart CsvRendered{..} = do - _partType .= decodeUtf8 typeCsv' - _partEncoding .= QuotedPrintableText - _partContent .= Csv.encodeByName csvRenderedHeader csvRenderedData - addAlternatives :: (MonadMail m) => Writer (PrioritisedAlternatives m) () diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index 7d20c7bca..3444afb07 100644 --- a/src/Model/Types/Misc.hs +++ b/src/Model/Types/Misc.hs @@ -123,3 +123,11 @@ instance FromJSON CsvOptions where derivePersistFieldJSON ''CsvOptions nullaryPathPiece ''CsvPreset $ camelToPathPiece' 2 + +instance YesodMail site => ToMailPart site (CsvRendered, CsvOptions) where + toMailPart (CsvRendered{..}, encOpts) = do + _partType .= decodeUtf8 typeCsv' + _partEncoding .= QuotedPrintableText + _partContent .= Csv.encodeByNameWith (encOpts ^. _CsvEncodeOptions) csvRenderedHeader csvRenderedData +instance YesodMail site => ToMailPart site CsvRendered where + toMailPart = toMailPart . (, def :: CsvOptions) From 2ddb56640fd0b5ac6bc7757e03b1819007cabd3a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 1 Oct 2019 09:38:18 +0200 Subject: [PATCH 37/38] fix(exam-users): make csv import much more lenient --- src/Handler/Exam/Users.hs | 31 ++++++++++++++++++++----------- 1 file changed, 20 insertions(+), 11 deletions(-) diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 966853113..87f8e1cb5 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -931,22 +931,31 @@ postEUsersR tid ssh csh examn = do guessUser :: ExamUserTableCsv -> DB (Bool, UserId) guessUser ExamUserTableCsv{..} = $cachedHereBinary (csvEUserMatriculation, csvEUserName, csvEUserSurname) $ do users <- E.select . E.from $ \user -> do - E.where_ . E.and $ catMaybes + E.where_ . E.or $ catMaybes [ (user E.^. UserMatrikelnummer E.==.) . E.val . Just <$> csvEUserMatriculation - , (user E.^. UserDisplayName E.==.) . E.val <$> csvEUserName - , (user E.^. UserSurname E.==.) . E.val <$> csvEUserSurname - , (user E.^. UserFirstName E.==.) . E.val <$> csvEUserFirstName + , (user E.^. UserDisplayName `E.hasInfix`) . E.val <$> csvEUserName + , (user E.^. UserSurname `E.hasInfix`) . E.val <$> csvEUserSurname + , (user E.^. UserFirstName `E.hasInfix`) . E.val <$> csvEUserFirstName ] let isCourseParticipant = E.exists . E.from $ \courseParticipant -> E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val examCourse E.&&. courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId - E.limit 2 - return (isCourseParticipant, user E.^. UserId) - case users of - (filter . view $ _1 . _Value -> [(E.Value isPart, E.Value uid)]) - -> return (isPart, uid) - [(E.Value isPart, E.Value uid)] - -> return (isPart, uid) + return (isCourseParticipant, user) + let users' = reverse $ sortBy closeness users + closeness :: (E.Value Bool, Entity User) -> (E.Value Bool, Entity User) -> Ordering + closeness = mconcat $ catMaybes + [ pure $ comparing (preview $ _2 . _entityVal . _userMatrikelnummer . only csvEUserMatriculation) + , pure $ comparing (view _1) + , csvEUserSurname <&> \surn -> comparing (preview $ _2 . _entityVal . _userSurname . to CI.mk . only (CI.mk surn)) + , csvEUserFirstName <&> \firstn -> comparing (preview $ _2 . _entityVal . _userFirstName . to CI.mk . only (CI.mk firstn)) + , csvEUserName <&> \dispn -> comparing (preview $ _2 . _entityVal . _userDisplayName . to CI.mk . only (CI.mk dispn)) + ] + case users' of + [(E.Value isPart, Entity uid _)] + -> return (isPart, uid) + (x@(E.Value isPart, Entity uid _) : x' : _) + | GT <- x `closeness` x' + -> return (isPart, uid) _other -> throwM ExamUserCsvExceptionNoMatchingUser From 6aa44b158561924459c912058ce1ab831a21f40a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 1 Oct 2019 09:46:24 +0200 Subject: [PATCH 38/38] chore(release): 7.3.2 --- CHANGELOG.md | 10 ++++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 13 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 88f0c833d..b4f2bc1d0 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,16 @@ 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. +### [7.3.2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.3.1...v7.3.2) (2019-10-01) + + +### Bug Fixes + +* **exam-users:** make csv import much more lenient ([2ddb566](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/2ddb566)) +* **mail:** honor userCsvOptions and userDisplayEmail ([89adf7f](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/89adf7f)) + + + ### [7.3.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.3.0...v7.3.1) (2019-09-30) diff --git a/package-lock.json b/package-lock.json index 9eb0c401c..e159c21a4 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "7.3.1", + "version": "7.3.2", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 9ae5e8d8f..9d2dd5e34 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "7.3.1", + "version": "7.3.2", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 64a18e649..9b0b96354 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 7.3.1 +version: 7.3.2 dependencies: - base >=4.9.1.0 && <5