diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs index 2f71cfd7c..32238bf12 100644 --- a/src/Handler/LMS/Userlist.hs +++ b/src/Handler/LMS/Userlist.hs @@ -163,7 +163,7 @@ mkUserlistTable sid qsh qid = do , LmsUserlistTimestamp =. now ] -- audit - lift $ queueDBJob $ JobLmsUserlist qid + lift . queueDBJob $ JobLmsUserlist qid return $ LmsUserlistR sid qsh dbtCsvRenderKey = const $ \case LmsUserlistInsertData{..} -> do -- TODO: i18n diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index faf8ec4ca..1d54bb162 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -12,13 +12,14 @@ module Model.Types.DateTime import Import.NoModel import qualified Data.Text as Text -import Data.Either.Combinators (maybeToRight, mapLeft) +-- import Data.Either.Combinators (maybeToRight, mapLeft) +import Text.Read (readMaybe) import Data.Time.Calendar.WeekDate -import Data.Time.Format.ISO8601 +-- import Data.Time.Format.ISO8601 -import qualified Text.Parsec as Parse (choice, parse, string, try) -import qualified Text.ParserCombinators.Parsec.Number as ParseNum (nat) +-- import qualified Text.Parsec as Parse (choice, parse, string, try) +-- import qualified Text.ParserCombinators.Parsec.Number as ParseNum (nat) import Database.Persist.Sql @@ -30,12 +31,14 @@ import Data.Aeson.Types as Aeson ---- -- Terms and anything loosely related to time -newtype TermIdentifier = TermIdentifier { getTermDay :: Day } +newtype TermIdentifier = TermIdentifier { year :: Integer } -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar' deriving (Show, Read, Eq, Ord, Generic, Typeable, Enum) - deriving newtype (Binary, ISO8601, PersistField, PersistFieldSql) + deriving newtype (Binary) -- , ISO8601, PersistField, PersistFieldSql) -- , ToJSON, FromJSON) deriving anyclass (NFData) -- ought to be equivalent to deriving stock (Show, Read, Eq, Ord, Generic, Typeable, Enum, Binary, NFData) +-- Note: Working Implementations for TermIdentifiers being single Days, half-years and quarters exits in git history + -- Conversion TermId <-> TermIdentifier:: -- from_TermId_to_TermIdentifier = unTermKey -- from_TermIdentifier_to_TermId = TermKey @@ -68,48 +71,16 @@ shortened = iso shorten expand -- Handler.Utils.Widget.tidFromText -- MsgTermPlaceHolder termToText :: TermIdentifier -> Text -termToText = termToText1 +termToText TermIdentifier{..} = Text.pack . show $ year ^. shortened termFromText :: Text -> Either Text TermIdentifier -termFromText t = termFromText1 t <> termFromText2 t - --- Option 1: date in iso8601, i.e. YYYY-MM-DD -termToText1 :: TermIdentifier -> Text -termToText1 = Text.pack . iso8601Show - -termFromText1 :: Text -> Either Text TermIdentifier -termFromText1 t = maybeToRight errm $ iso8601ParseM $ Text.unpack t - where - errm = "Invalid TermIdentifier: “" <> t <> "”" - --- Option 2: show as WeekNr-DayOfWeek-Year, e.g. 22Mon2021? -termToText2 :: TermIdentifier -> Text -termToText2 TermIdentifier{..} = Text.pack $ show weeknr ++ wd ++ show year - where - wd = take 3 $ show $ dayOfWeek getTermDay - (year,weeknr,_wd_) = toWeekDate getTermDay - -termFromText2 :: Text -> Either Text TermIdentifier -termFromText2 t = mapLeft (const errm) parseTerm - where - parseTerm = Parse.parse pWeekDate "termFromText2" $ Text.unpack t - - -- pWeekDate :: Parse.Parsec String () TermIdentifier - pWeekDate = do - wknr <- ParseNum.nat - dowk <- Parse.choice $ pDayOfWeek <$> (universe :: [DayOfWeek]) - year <- ParseNum.nat - case fromWeekDateValid year wknr (fromEnum dowk) of - (Just d) -> return $ TermIdentifier d - Nothing -> fail "invalid weekdate" - - -- pDayOfWeek :: DayOfWeek -> Parse.Parsec String () DayOfWeek - pDayOfWeek wd = do - void $ Parse.try $ Parse.string $ take 3 $ show wd - return wd - - errm = "Invalid TermIdentifier: “" <> t <> "”" - +termFromText t + | Just (review shortened -> year) <- readMaybe $ Text.unpack t + = Right TermIdentifier {..} + | otherwise + = Left $ "Invalid TermIdentifier: “" <> t <> "”; expected is just a year number." + + daysPerYear :: Rational daysPerYear = 365 + (97 % 400) @@ -122,20 +93,20 @@ dayOffset = fromIntegral yearzero + (fromIntegral diffstart / daysPerYear) -- Attempt to ensure that ``truncate . termToRational == fst3 . toGregorian . getTermDay´´ holds termToRational :: TermIdentifier -> Rational -termToRational = (dayOffset +) . (/ daysPerYear) . fromIntegral . fromEnum +termToRational = fromInteger . year termFromRational :: Rational -> TermIdentifier -termFromRational = toEnum . round . (daysPerYear *) . subtract dayOffset +termFromRational = TermIdentifier . floor + -{- -- For newtype Day, PersistField instance can be derived automatically instance PersistField TermIdentifier where toPersistValue = PersistRational . termToRational fromPersistValue (PersistRational t) = Right $ termFromRational t fromPersistValue x = Left $ "Expected TermIdentifier, received: " <> tshow x instance PersistFieldSql TermIdentifier where - sqlType _ = SqlNumeric 9 5 -- total significant digits; significant digits after decimal point --} + sqlType _ = SqlNumeric 4 0 -- total significant digits; significant digits after decimal point + instance ToHttpApiData TermIdentifier where toUrlPiece = termToText @@ -167,15 +138,17 @@ data TermDay deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving anyclass (Universe, Finite) +-- See Handler.Term.validateTerm for term specification guessDay :: TermIdentifier -> TermDay -> Day -guessDay TermIdentifier{..} TermDayLectureStart = getTermDay -guessDay TermIdentifier{..} TermDayLectureEnd = addDays 8 getTermDay -- courses last only a week -guessDay tid TermDayStart = fromWeekDate year week 1 -- Monday before lecture time - where ( year, week, _) = toWeekDate $ addDays (-7*4*3) $ guessDay tid TermDayLectureStart -guessDay tid TermDayEnd = fromWeekDate year week 7 -- Sunday after lecture time - where ( year, week, _) = toWeekDate $ addDays (7*3) $ guessDay tid TermDayLectureEnd +guessDay TermIdentifier{..} TermDayStart = fromWeekDate year weeknr wday -- Monday of first calendar week, might be within previous year + where weeknr = 1 -- 1st ISO8601 week + wday = 1 -- Monday +guessDay t TermDayLectureStart = guessDay t TermDayStart +guessDay t TermDayEnd = pred $ guessDay (succ t) TermDayStart +guessDay t TermDayLectureEnd = pred $ pred $ guessDay t TermDayEnd -- Friday of last calendar week, no lectures on Saturday/Sunday + withinTerm :: Day -> TermIdentifier -> Bool withinTerm d tid = guessDay tid TermDayStart <= d && d <= guessDay tid TermDayEnd diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index dd7e8b6e9..f4923612d 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -36,7 +36,7 @@ data Icon | IconProblem | IconVisible | IconInvisible - | IconCourse + -- | IconCourse -- not used, IconMenuCourse is currently only used | IconCourseFavouriteManual | IconCourseFavouriteAutomatic | IconCourseFavouriteOff | IconEnrolTrue | IconEnrolFalse @@ -109,27 +109,27 @@ data Icon iconText :: Icon -> Text iconText = \case - IconNew -> "seedling" - IconOK -> "check" - IconNotOK -> "times" - IconWarning -> "exclamation" - IconProblem -> "bolt" - IconVisible -> "eye" - IconInvisible -> "eye-slash" - IconCourse -> "chalkboard-teacher" -- From fontawesome v6 onwards: "chalkboard-user" / or "desktop" for both - IconCourseFavouriteManual -> "star" - IconCourseFavouriteAutomatic -> "star-half-alt" - IconCourseFavouriteOff -> "slash" -- TODO use FA regular style star for stacked icon - IconEnrolTrue -> "user-plus" - IconEnrolFalse -> "user-slash" - IconPlanned -> "cog" - IconAnnounce -> "bullhorn" - IconExam -> "poll-h" - IconExamRegisterTrue -> "calendar-check" - IconExamRegisterFalse -> "calendar-times" - IconExamAutoOccurrenceNudgeUp -> "user-plus" - IconExamAutoOccurrenceNudgeDown -> "user-minus" - IconExamAutoOccurrenceIgnore -> "users-slash" + IconNew -> "seedling" + IconOK -> "check" + IconNotOK -> "times" + IconWarning -> "exclamation" + IconProblem -> "bolt" + IconVisible -> "eye" + IconInvisible -> "eye-slash" + -- IconCourse -> "chalkboard-teacher" -- From fontawesome v6 onwards: "chalkboard-user" / or "desktop" for both + IconCourseFavouriteManual -> "star" + IconCourseFavouriteAutomatic -> "star-half-alt" + IconCourseFavouriteOff -> "slash" -- TODO use FA regular style star for stacked icon + IconEnrolTrue -> "user-plus" + IconEnrolFalse -> "user-slash" + IconPlanned -> "cog" + IconAnnounce -> "bullhorn" + IconExam -> "poll-h" + IconExamRegisterTrue -> "calendar-check" + IconExamRegisterFalse -> "calendar-times" + IconExamAutoOccurrenceNudgeUp -> "user-plus" + IconExamAutoOccurrenceNudgeDown -> "user-minus" + IconExamAutoOccurrenceIgnore -> "users-slash" IconExamAutoOccurrenceReconsider -> "users" IconCommentTrue -> "comment-alt" IconCommentFalse -> "comment-alt-slash" @@ -166,11 +166,11 @@ iconText = \case IconMenuLogout -> "sign-out-alt" IconBreadcrumbsHome -> "home" IconMenuExtra -> "ellipsis-h" - IconMenuCourseList -> "graduation-cap" -- "award" "diploma" "file-certificate" + IconMenuCourseList -> "chalkboard-teacher" -- From fontawesome v6 onwards: "chalkboard-user" / or "desktop" for both IconMenuCorrections -> "check" IconMenuExams -> "poll-h" IconMenuAdmin -> "screwdriver" - IconMenuLms -> "graduation-cap" + IconMenuLms -> "graduation-cap" -- "award" "diploma" "file-certificate" IconPageActionPrimaryExpand -> "bars" IconPageActionSecondary -> "ellipsis-h" IconBreadcrumbSeparator -> "angle-right" diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 0a7e5e406..17a3f2d34 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -62,20 +62,20 @@ fillDb = do insert' = fmap (either entityKey id) . insertBy addBDays = addBusinessDays Fraport -- holiday area to use - currentTerm = TermIdentifier $ utctDay now + currentTerm = TermIdentifier . fst3 . toGregorian $ utctDay now -- (currentYear, currentMonth, currentDay) = toGregorian $ getTermDay currentTerm - nextTerm n = TermIdentifier $ addBDays n $ getTermDay currentTerm + nextTerm n = toEnum . (+n) $ fromEnum currentTerm termTime :: TermIdentifier -- ^ Term -> TermDay -- ^ Relative to which day? - -> Integer -- ^ Business Days Offset from Start/End of Term + -> Integer -- ^ Week offset from TermDayStart/End of Term (shuld be negative for TermDayEnd) -> Maybe WeekDay -- ^ Move to weekday -> (Day -> UTCTime) -- ^ Add time to day -> UTCTime - termTime gTid gTD gOff mbWeekDay = ($ utctDay) + termTime gTid gTD weekOffset mbWeekDay = ($ tDay) where - gDay = addBDays gOff $ guessDay gTid gTD - utctDay = maybe gDay (`firstDayOfWeekOnAfter` gDay) mbWeekDay + gDay = addDays (7* weekOffset) $ guessDay gTid gTD + tDay = maybe gDay (`firstDayOfWeekOnAfter` gDay) mbWeekDay gkleen <- insert User { userIdent = "G.Kleen@campus.lmu.de" @@ -385,8 +385,8 @@ fillDb = do matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int) manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel - let tmin = -8 - tmax = 29*6 + let tmin = -1 + tmax = 2 trange = [tmin..tmax] dmin = guessDay (nextTerm tmin) TermDayStart dmax = guessDay (nextTerm tmax) TermDayEnd @@ -404,7 +404,7 @@ fillDb = do , termLectureEnd = guessDay tid TermDayLectureEnd } repsert tk term - insert_ $ TermActive tk (toMidnight $ addDays (-60) $ termStart term) (Just . beforeMidnight $ addDays 60 $ termEnd term) Nothing + insert_ $ TermActive tk (toMidnight $ termStart term) (Just . beforeMidnight $ termEnd term) Nothing return tk ifiAuthorshipStatement <- insertAuthorshipStatement I18n @@ -650,16 +650,14 @@ fillDb = do -- Fahrschule F forM_ terms $ \tk -> do let tid = unTermKey tk - jtt = (((Just .) .) .) . termTime tid - weekDay = dayOfWeek $ getTermDay tid + jtt = (((Just .) .) .) . termTime tid firstDay = utctDay $ termTime tid TermDayLectureStart 0 Nothing toMidnight secondDay = utctDay $ termTime tid TermDayLectureStart 1 Nothing toMidnight + weekDay = dayOfWeek firstDay -- thirdDay = utctDay $ termTime tid TermDayLectureStart 2 Nothing toMidnight capacity = Just 8 - mkName = CI.mk . (<> termToText2 tid) . (<> "_") - if weekDay `elem` [Friday, Saturday, Sunday] - then return () - else do + mkName = CI.mk + do c <- insert' Course { courseName = mkName "Vorfeldführerschein" , courseDescription = Just $ htmlToStoredMarkup [shamlet|