diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 86bb47969..6df8a8afa 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -1105,9 +1105,8 @@ th, td pointer-events: none #changelog - font-size: 14px - white-space: pre-wrap - font-family: var(--font-monospace) + max-height: 75vh + overflow: auto #gitrev font-size: 12px diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index b46939abf..a1ea08cbf 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -2809,4 +2809,7 @@ CronMatchAsap: ASAP CronMatchNone: Nie SystemExamOffice: Prüfungsverwaltung -SystemFaculty: Fakultätsmitglied \ No newline at end of file +SystemFaculty: Fakultätsmitglied + +ChangelogItemFeature: Feature +ChangelogItemBugfix: Bugfix \ No newline at end of file diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 79456dd64..fb29b90ad 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -2811,3 +2811,6 @@ CronMatchNone: Never SystemExamOffice: Exam office SystemFaculty: Faculty member + +ChangelogItemFeature: Feature +ChangelogItemBugfix: Bugfix \ No newline at end of file diff --git a/models/changelog.model b/models/changelog.model new file mode 100644 index 000000000..4cc42cb12 --- /dev/null +++ b/models/changelog.model @@ -0,0 +1,4 @@ +ChangelogItemFirstSeen + item ChangelogItem + firstSeen Day + Primary item diff --git a/src/Data/Time/Calendar/Instances.hs b/src/Data/Time/Calendar/Instances.hs index 15c77e94b..87e74ad1c 100644 --- a/src/Data/Time/Calendar/Instances.hs +++ b/src/Data/Time/Calendar/Instances.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Time.Calendar.Instances @@ -11,8 +10,13 @@ import Data.Time.Calendar import Data.Universe +import Language.Haskell.TH.Syntax (Lift) +import Type.Reflection -deriving newtype instance Hashable Day + +deriving instance Lift Day +instance Hashable Day where + hashWithSalt s (ModifiedJulianDay jDay) = s `hashWithSalt` hash (typeRep @Day) `hashWithSalt` jDay deriving instance Ord DayOfWeek instance Universe DayOfWeek where diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 399ed3793..1d5ac1248 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -225,6 +225,7 @@ embedRenderMessage ''UniWorX ''ExamAidsPreset id embedRenderMessage ''UniWorX ''ExamOnlinePreset id embedRenderMessage ''UniWorX ''ExamSynchronicityPreset id embedRenderMessage ''UniWorX ''ExamRequiredEquipmentPreset id +embedRenderMessage ''UniWorX ''ChangelogItemKind id embedRenderMessage ''UniWorX ''AuthenticationMode id diff --git a/src/Handler/Info.hs b/src/Handler/Info.hs index 7f4749bb6..c45c5c9d6 100644 --- a/src/Handler/Info.hs +++ b/src/Handler/Info.hs @@ -5,7 +5,9 @@ import Handler.Utils import Handler.Info.TH import qualified Data.Map as Map +import Data.Map ((!)) import qualified Data.CaseInsensitive as CI +import qualified Data.Set as Set import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E @@ -34,17 +36,26 @@ getLegalR = -- | Allgemeine Informationen getInfoR :: Handler Html -getInfoR = -- do +getInfoR = do + changelogEntries' <- runDB $ selectList [] [] + let changelogEntries = Map.fromListWith Set.union + [ (Down changelogItemFirstSeenFirstSeen, Set.singleton changelogItemFirstSeenItem) + | Entity _ ChangelogItemFirstSeen{..} <- changelogEntries' + ] + siteLayoutMsg MsgInfoHeading $ do setTitleI MsgInfoHeading let features = $(i18nWidgetFile "featureList") - changeLog = $(i18nWidgetFile "changelog") + changeLog = $(widgetFile "changelog") knownBugs = $(i18nWidgetFile "knownBugs") implementation = $(i18nWidgetFile "implementation") gitInfo :: Text gitInfo = $gitDescribe <> " (" <> $gitCommitDate <> ")" $(widgetFile "versionHistory") + where + changelogItems = $(i18nWidgetFiles "changelog") + getInfoLecturerR :: Handler Html getInfoLecturerR = @@ -67,9 +78,9 @@ getInfoLecturerR = -- new feature with given introduction date newFeat :: Integer -> Int -> Int -> WidgetFor UniWorX () - newFeat year month day = do + newFeat y m d = do currentTime <- liftIO getCurrentTime - let expiryTime = UTCTime (addGregorianMonthsRollOver 1 $ fromGregorian year month day) 0 + let expiryTime = UTCTime (addGregorianMonthsRollOver 1 $ fromGregorian y m d) 0 if currentTime > expiryTime then mempty else toWidget [whamlet| ^{iconTooltip tooltipNew (Just IconNew) False} |] diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index a321bebff..63bf227ac 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -213,9 +213,9 @@ formatDiffDays t setYear :: Integer -> Day -> Day -setYear year date = fromGregorian year month day +setYear year date = fromGregorian year m d where - (_,month,day) = toGregorian date + (_,m,d) = toGregorian date addOneWeek :: UTCTime -> UTCTime addOneWeek = addWeeks 1 @@ -295,7 +295,7 @@ formatTimeRangeMail = formatTimeRange' formatTimeMail formatGregorianW :: Integer -> Int -> Int -> Widget -formatGregorianW year month day = formatTimeW SelFormatDate $ fromGregorian year month day +formatGregorianW y m d = formatTimeW SelFormatDate $ fromGregorian y m d instance Csv.ToField ZonedTime where toField = Csv.toField . iso8601Show diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 55d1ee4ca..27657bbe5 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -45,6 +45,10 @@ import Web.ServerSession.Backend.Persistent.Memcached (migrateMemcachedSqlStorag import Data.Conduit.Algorithms.FastCDC (FastCDCParameters(fastCDCMinBlockSize)) +import Data.Time.Format.ISO8601 (iso8601Show) + +import qualified Data.Time.Zones as TZ + -- Database versions must follow https://pvp.haskell.org: -- - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format) -- - Non-breaking changes are instances where the automatic migration done by persistent is sufficient (i.e. adding a column or table) @@ -168,6 +172,19 @@ migrateManual = do , ("user_ldap_primary_key", "CREATE INDEX user_ldap_primary_key ON \"user\" (ldap_primary_key)" ) , ("file_content_entry_chunk_hash", "CREATE INDEX file_content_entry_chunk_hash ON \"file_content_entry\" (chunk_hash)" ) ] + + recordedChangelogItems <- lift . lift $ selectList [] [] + let missingChangelogItems = Set.toList $ Set.fromList universeF `Set.difference` recordedChangelogItems' + where recordedChangelogItems' = Set.fromList [ changelogItemFirstSeenItem | Entity _ ChangelogItemFirstSeen{..} <- recordedChangelogItems ] + unless (null missingChangelogItems) $ do + now <- iso8601Show . localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime + addMigration False $ + let sql = [st|INSERT INTO changelog_item_first_seen (item, first_seen) VALUES #{vals}|] + vals = Text.intercalate ", " $ do + item <- missingChangelogItems + return [st|('#{toPathPiece item}', '#{now}')|] + in sql + where addIndex :: Text -> Sql -> Migration addIndex ixName ixDef = do @@ -961,6 +978,15 @@ customMigrations = Map.fromListWith (>>) ALTER TABLE school ADD COLUMN "exam_discouraged_modes" jsonb NOT NULL DEFAULT #{ExamModeDNF predDNFFalse}; |] ) + , ( AppliedMigrationKey [migrationVersion|42.0.0|] [version|43.0.0|] + , unlessM (tableExists "changelog_item_first_seen") $ do + [executeQQ| + CREATE TABLE "changelog_item_first_seen" (PRIMARY KEY ("item"), "item" VARCHAR NOT NULL, "first_seen" DATE NOT NULL); + |] + insertMany_ [ ChangelogItemFirstSeen{..} + | (changelogItemFirstSeenItem, changelogItemFirstSeenFirstSeen) <- Map.toList changelogItemDays + ] + ) ] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index b40e5c912..a8e437f17 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -17,3 +17,4 @@ import Model.Types.Allocation as Types import Model.Types.Languages as Types import Model.Types.File as Types import Model.Types.User as Types +import Model.Types.Changelog as Types diff --git a/src/Model/Types/Changelog.hs b/src/Model/Types/Changelog.hs new file mode 100644 index 000000000..37d9828d5 --- /dev/null +++ b/src/Model/Types/Changelog.hs @@ -0,0 +1,145 @@ +module Model.Types.Changelog + ( ChangelogItem(..) + , changelogItemMap + , ChangelogItemKind(..), _ChangelogItemFeature, _ChangelogItemBugfix + , classifyChangelogItem + , changelogItemDays + ) where + +import Import.NoModel + +import Model.Types.TH.PathPiece + +import qualified Data.Map as Map + + +mkI18nWidgetEnum "Changelog" "changelog" +derivePersistFieldPathPiece ''ChangelogItem +pathPieceJSONKey ''ChangelogItem +pathPieceJSON ''ChangelogItem +pathPieceHttpApiData ''ChangelogItem + +data ChangelogItemKind + = ChangelogItemFeature + | ChangelogItemBugfix + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + +makePrisms ''ChangelogItemKind + +classifyChangelogItem :: ChangelogItem -> ChangelogItemKind +classifyChangelogItem = \case + ChangelogHaskellCampusLogin -> ChangelogItemBugfix + ChangelogTooltipsWithoutJavascript -> ChangelogItemBugfix + ChangelogButtonsWorkWithoutJavascript -> ChangelogItemBugfix + ChangelogTableFormsWorkAfterAjax -> ChangelogItemBugfix + ChangelogPassingByPointsWorks -> ChangelogItemBugfix + ChangelogErrorMessagesForTableItemVanish -> ChangelogItemBugfix + ChangelogExamAchievementParticipantDuplication -> ChangelogItemBugfix + ChangelogFormsTimesReset -> ChangelogItemBugfix + _other -> ChangelogItemFeature + +changelogItemDays :: Map ChangelogItem Day +changelogItemDays = Map.fromListWithKey (\k d1 d2 -> bool (error $ "Duplicate changelog days for " <> show k) d1 $ d1 /= d2) + [ (ChangelogConfigurableDatetimeFormat, [day|2018-07-10|]) + , (ChangelogCourseListOverAllTerms, [day|2018-07-31|]) + , (ChangelogCorrectionsDisplayImprovements, [day|2018-07-31|]) + , (ChangelogHaskellCampusLogin, [day|2018-08-01|]) + , (ChangelogFileDownloadOption, [day|2018-08-06|]) + , (ChangelogSheetsNoSubmissionAndZipControl, [day|2018-09-18|]) + , (ChangelogSmartCorrectionDistribution, [day|2018-09-18|]) + , (ChangelogTableSummaries, [day|2018-09-18|]) + , (ChangelogPersonalInformation, [day|2018-09-18|]) + , (ChangelogCourseShorthandsWithinSchools, [day|2018-09-18|]) + , (ChangelogTooltipsWithoutJavascript, [day|2018-09-18|]) + , (ChangelogEmailNotifications, [day|2018-10-19|]) + , (ChangelogSupportWidget, [day|2018-10-19|]) + , (ChangelogAccountDeletionDuringTesting, [day|2018-10-19|]) + , (ChangelogImprovementsForCorrectors, [day|2018-11-09|]) + , (ChangelogButtonsWorkWithoutJavascript, [day|2018-11-09|]) + , (ChangelogTableFormsWorkAfterAjax, [day|2018-11-29|]) + , (ChangelogPassingByPointsWorks, [day|2018-11-30|]) + , (ChangelogErrorMessagesForTableItemVanish, [day|2019-01-16|]) + , (ChangelogAssignedCorrectionsFilters, [day|2019-01-16|]) + , (ChangelogCourseConvenienceLinks, [day|2019-01-16|]) + , (ChangelogAsidenav, [day|2019-01-30|]) + , (ChangelogCourseAssociatedStudyField, [day|2019-03-20|]) + , (ChangelogStudyFeatures, [day|2019-03-27|]) + , (ChangelogCourseAdministratorRoles, [day|2019-03-27|]) + , (ChangelogCourseAdministratorInvitations, [day|2019-04-20|]) + , (ChangelogCourseMessages, [day|2019-04-20|]) + , (ChangelogCorrectorsOnCourseShow, [day|2019-04-29|]) + , (ChangelogTutorials, [day|2019-04-29|]) + , (ChangelogCourseMaterials, [day|2019-05-04|]) + , (ChangelogDownloadAllSheetFiles, [day|2019-05-10|]) + , (ChangelogImprovedSubmittorUi, [day|2019-05-10|]) + , (ChangelogCourseRegisterByAdmin, [day|2019-05-13|]) + , (ChangelogReworkedAutomaticCorrectionDistribution, [day|2019-05-20|]) + , (ChangelogDownloadAllSheetFilesByType, [day|2019-06-07|]) + , (ChangelogSheetSpecificFiles, [day|2019-06-07|]) + , (ChangelogExams, [day|2019-06-26|]) + , (ChangelogCsvExamParticipants, [day|2019-07-23|]) + , (ChangelogAllocationCourseRegistration, [day|2019-08-12|]) + , (ChangelogAllocationApplications, [day|2019-08-19|]) + , (ChangelogCsvCourseApplications, [day|2019-08-27|]) + , (ChangelogAllocationsNotifications, [day|2019-09-05|]) + , (ChangelogConfigurableDisplayEmails, [day|2019-09-12|]) + , (ChangelogConfigurableDisplayNames, [day|2019-09-12|]) + , (ChangelogEstimateAllocatedCourseCapacity, [day|2019-09-12|]) + , (ChangelogNotificationExamRegistration, [day|2019-09-13|]) + , (ChangelogExamClosure, [day|2019-09-16|]) + , (ChangelogExamOfficeExamNotification, [day|2019-09-16|]) + , (ChangelogExamOffices, [day|2019-09-16|]) + , (ChangelogExamAchievementParticipantDuplication, [day|2019-09-25|]) + , (ChangelogFormsTimesReset, [day|2019-09-25|]) + , (ChangelogExamAutomaticResults, [day|2019-09-25|]) + , (ChangelogExamAutomaticBoni, [day|2019-09-25|]) + , (ChangelogAutomaticallyAcceptCourseApplications, [day|2019-09-27|]) + , (ChangelogCourseNews, [day|2019-10-01|]) + , (ChangelogCsvExportCourseParticipants, [day|2019-10-08|]) + , (ChangelogNotificationCourseParticipantViaAdmin, [day|2019-10-08|]) + , (ChangelogCsvExportCourseParticipantsFeatures, [day|2019-10-09|]) + , (ChangelogCourseOccurences, [day|2019-10-09|]) + , (ChangelogTutorialRegistrationViaParticipantTable, [day|2019-10-10|]) + , (ChangelogCsvExportCourseParticipantsRegisteredTutorials, [day|2019-10-10|]) + , (ChangelogCourseParticipantsSex, [day|2019-10-14|]) + , (ChangelogTutorialTutorControl, [day|2019-10-14|]) + , (ChangelogCsvOptionCharacterSet, [day|2019-10-23|]) + , (ChangelogCsvOptionTimestamp, [day|2019-10-23|]) + , (ChangelogEnglish, [day|2019-10-31|]) + , (ChangelogI18n, [day|2019-10-31|]) + , (ChangelogLmuInternalFields, [day|2019-11-28|]) + , (ChangelogNotificationSubmissionChanged, [day|2019-12-05|]) + , (ChangelogExportCourseParticipants, [day|2020-01-17|]) + , (ChangelogExternalExams, [day|2020-01-17|]) + , (ChangelogExamAutomaticRoomDistribution, [day|2020-01-29|]) + , (ChangelogWarningMultipleSemesters, [day|2020-01-30|]) + , (ChangelogExamAutomaticRoomDistributionBetterRulesDisplay, [day|2020-01-30|]) + , (ChangelogReworkedNavigation, [day|2020-02-07|]) + , (ChangelogExamCorrect, [day|2020-02-08|]) + , (ChangelogExamGradingMode, [day|2020-02-19|]) + , (ChangelogMarkdownEmails, [day|2020-02-23|]) + , (ChangelogMarkdownHtmlInput, [day|2020-02-23|]) + , (ChangelogBetterCsvImport, [day|2020-03-06|]) + , (ChangelogAdditionalDatetimeFormats, [day|2020-03-16|]) + , (ChangelogServerSideSessions, [day|2020-03-16|]) + , (ChangelogWebinterfaceAllocationAllocation, [day|2020-03-16|]) + , (ChangelogBetterTableCellColourCoding, [day|2020-03-16|]) + , (ChangelogCourseOccurrenceNotes, [day|2020-03-31|]) + , (ChangelogHideSystemMessages, [day|2020-04-15|]) + , (ChangelogNonAnonymisedCorrection, [day|2020-04-17|]) + , (ChangelogBetterCourseParticipantDetailPage, [day|2020-04-17|]) + , (ChangelogFaq, [day|2020-04-24|]) + , (ChangelogRegisteredSubmissionGroups, [day|2020-04-28|]) + , (ChangelogFormerCourseParticipants, [day|2020-05-05|]) + , (ChangelogBetterFileUploads, [day|2020-05-05|]) + , (ChangelogSheetPassAlways, [day|2020-05-23|]) + , (ChangelogBetterCourseCommunicationTutorials, [day|2020-05-25|]) + , (ChangelogAdditionalSheetNotifications, [day|2020-05-25|]) + , (ChangelogCourseParticipantsListAddSheets, [day|2020-06-14|]) + , (ChangelogYamlRatings, [day|2020-06-17|]) + , (ChangelogSubmissionOnlyExamRegistered, [day|2020-07-20|]) + , (ChangelogCourseVisibility, [day|2020-08-10|]) + , (ChangelogPersonalisedSheetFiles, [day|2020-08-10|]) + , (ChangelogAbolishCourseAssociatedStudyFeatures, [day|2020-08-28|]) + ] diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs index dc2ce4677..0ef6ca5a0 100644 --- a/src/Utils/DateTime.hs +++ b/src/Utils/DateTime.hs @@ -12,6 +12,7 @@ module Utils.DateTime , nominalHour, nominalMinute , minNominalYear, avgNominalYear , module Zones + , day ) where import ClassyPrelude.Yesod hiding (lift) @@ -23,12 +24,14 @@ import Data.Time.Zones.TH as Zones (includeSystemTZ) import Data.Time.Zones (localTimeToUTCTZ, timeZoneForUTCTime) import Data.Time.Format (FormatTime) import Data.Time.Clock.System (systemEpochDay) +import qualified Data.Time.Format.ISO8601 as Time import qualified Data.Time.Format as Time import qualified Data.List.NonEmpty as NonEmpty import Language.Haskell.TH import Language.Haskell.TH.Syntax (Lift(..)) +import Language.Haskell.TH.Quote (QuasiQuoter(..)) import Instances.TH.Lift () import Data.Data (Data) @@ -144,3 +147,15 @@ nominalMinute = 60 minNominalYear, avgNominalYear :: NominalDiffTime minNominalYear = 365 * nominalDay avgNominalYear = fromRational $ 365.2425 * toRational nominalDay + +--------- +-- Day -- +--------- + +day :: QuasiQuoter +day = QuasiQuoter{..} + where + quotePat = error "day used as pattern" + quoteType = error "day used as type" + quoteDec = error "day used as declaration" + quoteExp dStr = maybe (fail $ "Could not parse ISO8601 day: “" <> dStr <> "”") (lift :: Day -> Q Exp) $ Time.iso8601ParseM dStr diff --git a/src/Utils/PathPiece.hs b/src/Utils/PathPiece.hs index 939f47058..1d466b689 100644 --- a/src/Utils/PathPiece.hs +++ b/src/Utils/PathPiece.hs @@ -8,6 +8,7 @@ module Utils.PathPiece , tuplePathPiece , pathPieceJSON, pathPieceJSONKey , pathPieceBinary + , pathPieceHttpApiData ) where import ClassyPrelude.Yesod @@ -40,6 +41,8 @@ import qualified Data.Binary as Binary import Control.Lens import Data.Generics.Product.Types +import Web.HttpApiData + mkFiniteFromPathPiece :: Name -> Q ([Dec], Exp) mkFiniteFromPathPiece finiteType = do @@ -229,3 +232,11 @@ pathPieceBinary tName get = Binary.get >>= maybe (fail $ "Could not parse value of " <> $(TH.lift $ nameBase tName) <> " via PathPiece") return . fromPathPiece put = Binary.put . toPathPiece |] + +pathPieceHttpApiData :: Name -> DecsQ +pathPieceHttpApiData tName + = [d| instance ToHttpApiData $(conT tName) where + toUrlPiece = toPathPiece + instance FromHttpApiData $(conT tName) where + parseUrlPiece = maybe (Left $ "Could not parse value of " <> $(TH.lift $ nameBase tName) <> " via PathPiece") Right . fromPathPiece + |] diff --git a/templates/changelog.hamlet b/templates/changelog.hamlet new file mode 100644 index 000000000..88f977759 --- /dev/null +++ b/templates/changelog.hamlet @@ -0,0 +1,14 @@ +$newline never +
+ $forall (Down d, es) <- Map.toList changelogEntries +
toPathPiece d}> + ^{formatTimeW SelFormatDate d} +
+