Rounded time for visibility defaults

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)
 

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

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)

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