diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index b738e0105..b644fe3f4 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -10,7 +10,7 @@ import qualified Database.Esqueleto as E import Utils.Lens import Utils.Form -import Handler.Utils.Form +import Handler.Utils data MaterialForm = MaterialForm { @@ -41,7 +41,7 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do return $ material E.^. MaterialType return $ defaults <> (Set.fromList $ mapMaybe E.unValue previouslyUsed) - ctime <- liftIO $ getCurrentTime + ctime <- ceilingQuarterHour <$> liftIO getCurrentTime flip (renderAForm FormStandard) html $ MaterialForm <$> areq ciField (fslI MsgMaterialName) (mfName <$> template) <*> aopt (textField & addDatalist typeOptions) @@ -50,7 +50,7 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do <*> aopt htmlField (fslpI MsgMaterialDescription "Html") (mfDescription <$> template) <*> aopt utcTimeField (fslI MsgMaterialVisibleFrom - & setTooltip MsgMaterialVisibleFromTip) ((mfVisibleFrom <$> template) <|> pure (Just ctime)) + & setTooltip MsgMaterialVisibleFromTip) ((mfVisibleFrom <$> template) <|> pure (Just ctime)) <*> aopt (multiFileField oldFileIds) (fslI MsgMaterialFiles) (mfFiles <$> template) diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 92f79ed39..bd65e4d09 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -96,7 +96,7 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do Nothing -> return $ partitionFileType mempty (Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId mr <- getMsgRenderer - ctime <- liftIO $ getCurrentTime + ctime <- ceilingQuarterHour <$> liftIO getCurrentTime (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm <$> areq ciField (fslI MsgSheetName) (sfName <$> template) <*> aopt htmlField (fslpI MsgSheetDescription "Html") diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 15ecfc780..8c42f549d 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -9,6 +9,7 @@ module Handler.Utils.DateTime , addOneWeek, addWeeks , weeksToAdd , setYear + , ceilingQuarterHour ) where import Import @@ -185,3 +186,17 @@ weeksToAdd old new = loop 0 old loop n t | t > new = n | otherwise = loop (succ n) (addOneWeek t) + +-- | round up the next full quarter hour with a margin of at least 5 minutes +ceilingQuarterHour :: UTCTime -> UTCTime +ceilingQuarterHour = ceilingMinuteBy 5 15 + +-- | round up the next full @roundto@ minutes with a margin of at least @margin@ minutes +ceilingMinuteBy :: Int -> Int -> UTCTime -> UTCTime +ceilingMinuteBy margin roundto utct = addUTCTime bonus utct + where + oldTime = localTimeOfDay $ utcToLocalTime utct + oldMin = todMin oldTime + newMin = roundToNearestMultiple roundto $ oldMin + margin + newTime = oldTime { todMin = newMin, todSec = 0} -- might be invalid, but correctly treated by `timeOfDayToTime` + bonus = realToFrac $ (timeOfDayToTime newTime) - (timeOfDayToTime oldTime) \ No newline at end of file diff --git a/src/Utils.hs b/src/Utils.hs index 40fa580ee..3ac062bcf 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -269,6 +269,17 @@ notUsedT = notUsed +------------- +-- Numeric -- +------------- + +-- | round n to nearest multiple of m +roundToNearestMultiple :: Int -> Int -> Int +roundToNearestMultiple m n = (n `div` m + 1) * m + + + + ------------ -- Monoid -- ------------ @@ -495,7 +506,7 @@ maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return maybeTExceptT :: Monad m => e -> MaybeT m b -> ExceptT e m b maybeTExceptT err act = maybeExceptT err $ runMaybeT act - + maybeTMExceptT :: Monad m => m e -> MaybeT m b -> ExceptT e m b maybeTMExceptT err act = maybeMExceptT err $ runMaybeT act