From 7a684f6cb60a807667634ae7848ff02df630724a Mon Sep 17 00:00:00 2001
From: SJost <jost@tcs.ifi.lmu.de>
Date: Tue, 5 Feb 2019 23:11:31 +0100
Subject: [PATCH] FIxes #262

---
 src/Foundation.hs             |  2 +-
 src/Handler/Sheet.hs          | 39 +++++++++++++++++++----------------
 src/Handler/Utils/DateTime.hs | 30 ++++++++++++++++++++-------
 3 files changed, 45 insertions(+), 26 deletions(-)

diff --git a/src/Foundation.hs b/src/Foundation.hs
index 32af16476..27e13bb45 100644
--- a/src/Foundation.hs
+++ b/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
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index e798f9ca9..4692468ea 100644
--- a/src/Handler/Sheet.hs
+++ b/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
diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs
index 890990027..69ace7b97 100644
--- a/src/Handler/Utils/DateTime.hs
+++ b/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
-