FIxes #262

src/Foundation.hs

@@ -474,7 +474,7 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
       (Just (Entity _ Course{courseRegisterFrom, courseRegisterTo}))
         | not registered
         , maybe False (now >=) courseRegisterFrom -- Nothing => no registration allowed
-        , maybe True  (now <=) courseRegisterTo -> return Authorized
+        , maybe True  (now <=) courseRegisterTo      -> return Authorized
       (Just (Entity _ Course{courseDeregisterUntil}))
         | registered
         , maybe True  (now <=) courseDeregisterUntil -> return Authorized

src/Handler/Sheet.hs

@@ -444,25 +444,28 @@ getSheetNewR tid ssh csh = do
       E.orderBy [E.desc (sheet E.^. SheetActiveFrom)]
       E.limit 1
       return sheet
+  now <- liftIO getCurrentTime
   let template = case lastSheets of
-        ((Entity {entityVal=Sheet{..}}):_)  -> Just $ SheetForm
-          { sfName         = stepTextCounterCI sheetName
-          , sfDescription  = sheetDescription
-          , sfType         = sheetType
-          , sfGrouping     = sheetGrouping
-          , sfVisibleFrom  = addOneWeek <$> sheetVisibleFrom
-          , sfActiveFrom   = addOneWeek     sheetActiveFrom
-          , sfActiveTo     = addOneWeek     sheetActiveTo
-          , sfSubmissionMode = sheetSubmissionMode
-          , sfUploadMode   = sheetUploadMode
-          , sfSheetF       = Nothing
-          , sfHintFrom     = addOneWeek <$> sheetHintFrom
-          , sfHintF        = Nothing
-          , sfSolutionFrom = addOneWeek <$> sheetSolutionFrom
-          , sfSolutionF    = Nothing
-          , sfMarkingF     = Nothing
-          , sfMarkingText  = sheetMarkingText
-          }
+        ((Entity {entityVal=Sheet{..}}):_)  ->
+          let addTime = addWeeks $ max 1 $ succ $ weekDiff sheetActiveTo now
+          in Just $ SheetForm
+            { sfName         = stepTextCounterCI sheetName
+            , sfDescription  = sheetDescription
+            , sfType         = sheetType
+            , sfGrouping     = sheetGrouping
+            , sfVisibleFrom  = addTime <$> sheetVisibleFrom
+            , sfActiveFrom   = addTime     sheetActiveFrom
+            , sfActiveTo     = addTime     sheetActiveTo
+            , sfSubmissionMode = sheetSubmissionMode
+            , sfUploadMode   = sheetUploadMode
+            , sfSheetF       = Nothing
+            , sfHintFrom     = addTime <$> sheetHintFrom
+            , sfHintF        = Nothing
+            , sfSolutionFrom = addTime <$> sheetSolutionFrom
+            , sfSolutionF    = Nothing
+            , sfMarkingF     = Nothing
+            , sfMarkingText  = sheetMarkingText
+            }
         _other -> Nothing
   let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing
         insertUnique $ newSheet

src/Handler/Utils/DateTime.hs

@@ -5,7 +5,8 @@ module Handler.Utils.DateTime
   , getTimeLocale, getDateTimeFormat
   , validDateTimeFormats, dateTimeFormatOptions
   , formatTimeMail
-  , addOneWeek
+  , addOneWeek, addWeeks
+  , weekDiff
   ) where
 
 import Import
@@ -14,7 +15,7 @@ import Data.Time.Zones
 import qualified Data.Time.Zones as TZ
 
 import Data.Time hiding (formatTime, localTimeToUTC, utcToLocalTime)
-import Data.Time.Clock (addUTCTime,nominalDay)
+-- import Data.Time.Clock (addUTCTime,nominalDay)
 import qualified Data.Time.Format as Time
 
 import Data.Set (Set)
@@ -125,14 +126,29 @@ dateTimeFormatOptions sel = do
 
   let
     toOption fmt@DateTimeFormat{..} = do
-      dateTime <- formatTime' unDateTimeFormat now 
+      dateTime <- formatTime' unDateTimeFormat now
       return (dateTime, fmt)
-  
-  optionsPairs <=< mapM toOption . Set.toList $ validDateTimeFormats tl sel 
+
+  optionsPairs <=< mapM toOption . Set.toList $ validDateTimeFormats tl sel
 
 
 addOneWeek :: UTCTime -> UTCTime
-addOneWeek = addUTCTime (7 * nominalDay)
+addOneWeek = addWeeks 1
+
+addWeeks :: Integer -> UTCTime -> UTCTime
+addWeeks n utct = utct { utctDay = newDay }
+  where
+    oldDay = utctDay utct
+    -- newDay = addGregorianDurationRollOver $ stimes n calendarWeek -- only available in newer version 1.9 of Data.Time.Calendar
+    newDay = addDays (7*n) oldDay
+
+weekDiff :: UTCTime -> UTCTime -> Integer
+-- ^ Difference between times, rounded down to weeks
+weekDiff old new = dayDiff `div` 7
+  where
+    dayOld  = utctDay old
+    dayNew  = utctDay new
+    dayDiff = diffDays dayNew dayOld
+
 
 -- addOneTerm? -> Move Handler.Utils.DateTime
-