Merge branch 'term2days' into 'master'

Term2days

See merge request FraDrive/fradrive!5

messages/uniworx/categories/I18n/de-de-formal.msg

@@ -1,11 +1,3 @@
-Quarter1st year@Integer: Erstes Quartal #{year}
-Quarter2nd year@Integer: Zweites Quartal #{year}
-Quarter3rd year@Integer: Drittes Quartal #{year}
-Quarter4th year@Integer: Viertes Quartal #{year}
-Quarter1stShort year@Integer: #{year}/Q1
-Quarter2ndShort year@Integer: #{year}/Q2
-Quarter3rdShort year@Integer: #{year}/Q3 
-Quarter4thShort year@Integer: #{year}/Q4
 CorByProportionOnly proportion@Rational: #{rationalToFixed3 proportion} Anteile
 CorByProportionIncludingTutorial proportion@Rational: #{rationalToFixed3 proportion} Anteile - Tutorium
 CorByProportionExcludingTutorial proportion@Rational: #{rationalToFixed3 proportion} Anteile + Tutorium

messages/uniworx/categories/I18n/en-eu.msg

@@ -1,11 +1,3 @@
-Quarter1st year@Integer: First Quarter of #{year}
-Quarter2nd year@Integer: Second Quarter of #{year}
-Quarter3rd year@Integer: Third Quarter of #{year}
-Quarter4th year@Integer: Last Quarter of #{year}
-Quarter1stShort year@Integer: #{year}/Q1st
-Quarter2ndShort year@Integer: #{year}/Q2nd
-Quarter3rdShort year@Integer: #{year}/Q3rd 
-Quarter4thShort year@Integer: #{year}/Q4th
 CorByProportionOnly proportion: #{rationalToFixed3 proportion} parts
 CorByProportionIncludingTutorial proportion: #{rationalToFixed3 proportion} parts - tutorials
 CorByProportionExcludingTutorial proportion: #{rationalToFixed3 proportion} parts + tutorials

nix/docker/default.nix

@@ -21,7 +21,11 @@ let
     contents = with final; [
       uniworx.uniworx.components.exes.uniworx
       prev.dockerTools.binSh findutils coreutils
-      curl wget
+      cups # needed for interface with print center 
+      texlive.combined.scheme-medium # probably needed by pandoc library to produce PDFs?
+      # For manual testing, maybe remove for production?
+      curl wget pandoc
+
     ] ++ optionals isDemo [ postgresql_12 memcached uniworx.uniworx.components.exes.uniworxdb ];
 
     runAsRoot = ''

routes

@@ -69,6 +69,7 @@
 /info/glossary                GlossaryR        GET             !free
 /info/faq                     FaqR             GET             !free
 /version                      VersionR         GET             !free
+/status                       StatusR          GET             !free 
 
 /help                         HelpR            GET POST        !free
 

src/Application.hs

@@ -1,6 +1,6 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
  
-module Application
+module Application 
     ( getAppSettings, getAppDevSettings
     , appMain
     , develMain

src/Foundation/I18n.hs

@@ -195,20 +195,10 @@ mkMessageVariant ''UniWorX ''ButtonMessage "messages/button" "de"
 mkMessageVariant ''UniWorX ''FrontendMessage "messages/frontend" "de-de-formal"
 
 instance RenderMessage UniWorX TermIdentifier where
-  renderMessage foundation ls TermIdentifier{..} = case season of
+  renderMessage _foundation _ls = termToText -- TODO: respect user selected Datetime Format
-    Q1 -> renderMessage' $ MsgQuarter1st year
-    Q2 -> renderMessage' $ MsgQuarter2nd year
-    Q3 -> renderMessage' $ MsgQuarter3rd year
-    Q4 -> renderMessage' $ MsgQuarter4th year
-    where renderMessage' = renderMessage foundation ls
 
 instance RenderMessage UniWorX ShortTermIdentifier where
-  renderMessage foundation ls (ShortTermIdentifier TermIdentifier{..}) = case season of
+  renderMessage _foundation _ls (ShortTermIdentifier tid) = termToText tid -- TODO: implement shorttermidentifier properly
-    Q1 -> renderMessage' $ MsgQuarter1stShort year
-    Q2 -> renderMessage' $ MsgQuarter2ndShort year
-    Q3 -> renderMessage' $ MsgQuarter3rdShort year
-    Q4 -> renderMessage' $ MsgQuarter4thShort year
-    where renderMessage' = renderMessage foundation ls
 
 instance RenderMessage UniWorX String where
   renderMessage f ls str = renderMessage f ls $ Text.pack str

src/Foundation/Navigation.hs

@@ -132,6 +132,7 @@ breadcrumb HelpR            = i18nCrumb MsgMenuHelp            Nothing
 
 breadcrumb HealthR          = i18nCrumb MsgMenuHealth          Nothing
 breadcrumb InstanceR        = i18nCrumb MsgMenuInstance        Nothing
+breadcrumb StatusR          = i18nCrumb MsgMenuHealth          Nothing  -- never displayed
 
 breadcrumb ProfileR         = i18nCrumb MsgBreadcrumbProfile   Nothing
 breadcrumb SetDisplayEmailR = i18nCrumb MsgUserDisplayEmail  $ Just ProfileR

src/Handler/Allocation/Form.hs

@@ -159,8 +159,7 @@ suggestAllocationForm (Set.fromList . map optionInternalValue . olOptions -> ter
   newTerm <- MaybeT $ get tid
   Entity _ Allocation{..} <- MaybeT . getBy $ TermSchoolAllocationShort oldTid ssh ash
 
-  let dayOffset = (diffDays `on` termLectureStart) newTerm oldTerm
+  let addTime = addLocalDays $ (diffDays `on` termLectureStart) newTerm oldTerm      
-      addTime = addLocalDays dayOffset
 
   return AllocationForm
     { afTerm = tid

src/Handler/Course/Edit.hs

@@ -435,7 +435,7 @@ getCourseNewR = do
             let newTemplate = courseToForm oldTemplate mempty mempty Nothing in
             return $ Just $ newTemplate
                 { cfCourseId   = Nothing
-                , cfTerm       = TermKey $ TermIdentifier 0 Q1 -- invalid, will be ignored; undefined won't work due to strictness
+                , cfTerm       = TermKey $ termFromRational 0 -- invalid, will be ignored; undefined won't work due to strictness
                 , cfRegFrom    = Nothing
                 , cfRegTo      = Nothing
                 , cfDeRegUntil = Nothing

src/Handler/Health.hs

@@ -11,6 +11,9 @@ import qualified Data.Set as Set
 
 import Control.Concurrent.STM.Delay
 
+import Language.Haskell.TH (stringE,runIO)
+
+-- import Data.FileEmbed (embedStringFile)
 
 getHealthR :: Handler TypedContent
 getHealthR = do
@@ -94,3 +97,31 @@ getInstanceR = do
         |]
     provideJson instanceInfo
     provideRep . return $ tshow instanceInfo
+
+
+-- Most simple page for simple liveness checks
+getStatusR :: Handler Html
+getStatusR = withUrlRenderer
+    [hamlet|
+      $doctype 5
+      <html lang=en>
+        <head>        
+          <title>Alive
+        <body>
+          <p>
+            Compile Time {#{comptime}}
+    |]
+      {-
+          <p>
+            Alive #{vnr_full}
+          <p>
+            Demo #{vnr_demo}
+          <p>
+            CI #{vnr_ci}
+      -}
+  where 
+    -- vnr_full :: Text = $(embedStringFile "./nix/docker/version.json")
+    -- vnr_demo :: Text = $(embedStringFile "./nix/docker/demo-version.json")
+    -- vnr_ci   :: Text = $(embedStringFile "./nix/docker/ci-version.json")
+    comptime :: Text = $(stringE =<< runIO (show <$> getCurrentTime))
+  

src/Handler/Term.hs

@@ -25,8 +25,7 @@ import qualified Control.Monad.State.Class as State
 validateTerm :: (MonadHandler m, HandlerSite m ~ UniWorX)
              => FormValidator TermForm m ()
 validateTerm = do
-  TermForm{..} <- State.get
+  TermForm{..} <- State.get  
-  guardValidation MsgTermStartMustMatchName $ tfStart `withinTermYear` tfName
   guardValidation MsgTermEndMustBeAfterStart $ tfStart < tfEnd
   guardValidation MsgTermLectureEndMustBeAfterStart $ tfLectureStart < tfLectureEnd
   guardValidation MsgTermStartMustBeBeforeLectureStart $ tfStart <= tfLectureStart

src/Handler/Utils/DateTime.hs

@@ -16,6 +16,7 @@ module Handler.Utils.DateTime
   , addOneWeek, addWeeks
   , weeksToAdd
   , setYear, getYear
+  , firstDayOfWeekOnAfter
   , ceilingQuarterHour
   , formatGregorianW
   ) where
@@ -224,6 +225,14 @@ getYear date = y
   where 
     (y,_,_) = toGregorian date    
 
+dayOfWeekDiff :: DayOfWeek -> DayOfWeek -> Int
+dayOfWeekDiff a b = mod (fromEnum a - fromEnum b) 7
+
+-- | The first day-of-week on or after some day
+-- | from time-compat-1.9.5, not included
+firstDayOfWeekOnAfter :: DayOfWeek -> Day -> Day
+firstDayOfWeekOnAfter dw d = addDays (toInteger $ dayOfWeekDiff dw $ dayOfWeek d) d
+
 addOneWeek :: UTCTime -> UTCTime
 addOneWeek = addWeeks 1
 

src/Model/Types/DateTime.hs

@@ -12,11 +12,10 @@ module Model.Types.DateTime
 import Import.NoModel
 
 import qualified Data.Text as Text
-import qualified Data.CaseInsensitive as CI
 import Data.Either.Combinators (maybeToRight)
-import Text.Read (readMaybe)
 
 import Data.Time.Calendar.WeekDate
+import Data.Time.Format.ISO8601
 
 import Database.Persist.Sql
 
@@ -26,45 +25,13 @@ import Data.Aeson.Types as Aeson
 
 
 ----
---  Terms, Seaons, anything loosely related to time
+--  Terms and anything loosely related to time
 
-data Season = Q1 | Q2 | Q3 | Q4
+newtype TermIdentifier = TermIdentifier { getTermDay :: Day }
-  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable)
+    deriving (Show, Read, Eq, Ord, Generic, Typeable, Enum)     
-  deriving anyclass (Binary, Universe, Finite, NFData)
+    deriving newtype (Binary, ISO8601, PersistField, PersistFieldSql)
-
+    deriving anyclass (NFData)
-numSeasons :: Int -- to be flexible
+    -- ought to be equivalent to deriving stock (Show, Read, Eq, Ord, Generic, Typeable, Enum, Binary, NFData)
-numSeasons = succ $ fromEnum(maxBound::Season)
-
-seasonFromText' :: Text -> Either Text Season
-seasonFromText' t = maybeToRight errmsg (readMaybe $ Text.unpack $ Text.toUpper t)
-  where 
-    errmsg = "Invalid season: ‘" <> tshow t <> "’"
-
-seasonFromText :: Text -> Either Text Season
-seasonFromText t 
-  | Just (q, ne) <- Text.uncons t
-  , q ~= 'Q'
-  , Just (n, e)  <- Text.uncons ne
-  , Text.null e = case n of '1' -> Right Q1 
-                            '2' -> Right Q2
-                            '3' -> Right Q3
-                            '4' -> Right Q4
-                            _   -> Left $ "Invalid quarter number: ‘" <> tshow t <> "’"
-  | otherwise = Left $ "Invalid season: ‘" <> tshow t <> "’"
-  where
-    (~=) :: Char -> Char -> Bool
-    (~=) = (==) `on` CI.mk
-
-data TermIdentifier = TermIdentifier
-  { year :: Integer -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar'
-  , season :: Season
-  } deriving (Show, Read, Eq, Ord, Generic, Typeable)
-    deriving anyclass (Binary, NFData)
-
-instance Enum TermIdentifier where
-  -- ^ Do not use for conversion – Enumeration only
-  toEnum int = let (toInteger -> year, toEnum -> season) = int `divMod` numSeasons in TermIdentifier{..}
-  fromEnum TermIdentifier{..} = fromInteger year * numSeasons + fromEnum season
 
 -- Conversion TermId <-> TermIdentifier::
 -- from_TermId_to_TermIdentifier = unTermKey
@@ -94,40 +61,56 @@ shortened = iso shorten expand
       , year < $currentYear + 50 = year `mod` 100
       | otherwise = year
 
+-- Option 1: date in iso8601 
 termToText :: TermIdentifier -> Text
-termToText TermIdentifier{..} = Text.pack $ show (year ^. shortened) ++ show season
+termToText = Text.pack . iso8601Show
 
 -- also see Hander.Utils.tidFromText
 termFromText :: Text -> Either Text TermIdentifier
-termFromText t
+termFromText t = maybeToRight errm $ iso8601ParseM $ Text.unpack t
-  | (ys,s) <- Text.break (~= 'Q') t
+  where 
-  , Right season <- seasonFromText s
+      errm = "Invalid TermIdentifier: “" <> t <> "”"
-  , Just (review shortened -> year) <- readMaybe $ Text.unpack ys
-  = Right TermIdentifier{..}
-  | otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”" -- TODO: Could be improved, I.e. say "W"/"S" from Number
-  where
-    (~=) :: Char -> Char -> Bool
-    (~=) = (==) `on` CI.mk
 
-termToRational :: TermIdentifier -> Rational
+-- Option 2: show as WeekNr-DayOfWeek-Year, e.g. 22Mon2021?
-termToRational TermIdentifier{..} = toRational year + seasonOffset
+termToText' :: TermIdentifier -> Text 
-  where
+termToText' TermIdentifier{..} = Text.pack $ show weeknr ++ wd ++ show year
-    seasonOffset = fromIntegral (fromEnum season) % fromIntegral numSeasons
+  where 
+    wd = take 3 $ show $ dayOfWeek getTermDay
+    (year,weeknr,_wd_) = toWeekDate getTermDay
+
+{- TODO
+termFromText' :: Text -> Either Text TermIdentifier
+termFromText' t = error "not implemented"
+  where 
+      errm = "Invalid TermIdentifier: “" <> t <> "”"
+-}
+
+daysPerYear :: Rational
+daysPerYear = 365 + (97 % 400)
+
+dayOffset :: Rational 
+dayOffset = fromIntegral yearzero + (fromIntegral diffstart / daysPerYear)
+  where     
+    dayzero   = toEnum 0
+    yearzero  = fst3 $ toGregorian dayzero
+    diffstart = diffDays dayzero $ fromGregorian yearzero 1 1 
+    
+-- Attempt to ensure that ``truncate . termToRational == fst3 . toGregorian . getTermDay´´ holds
+termToRational :: TermIdentifier -> Rational 
+termToRational = (dayOffset +) . (/ daysPerYear) . fromIntegral . fromEnum        
 
 termFromRational :: Rational -> TermIdentifier
-termFromRational n = TermIdentifier{..}
+termFromRational = toEnum . round . (daysPerYear *) . subtract dayOffset
-  where
-    year = floor n 
-    remainder = n - fromInteger (floor n)  -- properFraction problematic for negative year values 
-    season = toEnum $ floor $ remainder * fromIntegral numSeasons
 
+{- -- 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 5 1
+  sqlType _ = SqlNumeric 9 5 -- total significant digits; significant digits after decimal point
+-}
 
 instance ToHttpApiData TermIdentifier where
   toUrlPiece = termToText
@@ -162,27 +145,16 @@ data TermDay
 guessDay :: TermIdentifier
          -> TermDay
          -> Day
-guessDay TermIdentifier{ year, season = Q1 } TermDayStart  = fromGregorian year  1  1
+guessDay TermIdentifier{..} TermDayLectureStart =           getTermDay
-guessDay TermIdentifier{ year, season = Q2 } TermDayStart  = fromGregorian year  4  1
+guessDay TermIdentifier{..} TermDayLectureEnd   = addDays 8 getTermDay -- courses last only a week
-guessDay TermIdentifier{ year, season = Q3 } TermDayStart  = fromGregorian year  7  1
+guessDay tid TermDayStart = fromWeekDate year week 1 -- Monday before lecture time 
-guessDay TermIdentifier{ year, season = Q4 } TermDayStart  = fromGregorian year 10  1
+  where ( year, week, _) = toWeekDate $ addDays (-7*4*3) $ guessDay tid TermDayLectureStart
-guessDay tid TermDayEnd = pred $ guessDay (succ tid) TermDayStart
+guessDay tid TermDayEnd   = fromWeekDate year week 7 -- Sunday after lecture time
-guessDay tid TermDayLectureStart = fromWeekDate year weekStart 1 -- first Monday within Quarter
+  where ( year, week, _) = toWeekDate $ addDays (7*3) $ guessDay tid TermDayLectureEnd
-  where ( year, weekStart, _) = toWeekDate $ guessDay tid TermDayStart
-guessDay tid TermDayLectureEnd   = fromWeekDate year weekStart 5 -- Friday of last week within Quarter
-  where ( year, weekStart, _) = toWeekDate $ guessDay tid TermDayEnd
 
 withinTerm :: Day -> TermIdentifier -> Bool 
 withinTerm d tid = guessDay tid TermDayStart <= d && d <= guessDay tid TermDayEnd
 
--- | Check only if last two digits within the year numbers match
-withinTermYear :: Day -> TermIdentifier -> Bool
-time `withinTermYear` term = timeYear `mod` 100 == termYear `mod` 100
-  where
-    timeYear = fst3 $ toGregorian time
-    termYear = year term
-
-
 data OccurrenceSchedule = ScheduleWeekly
                           { scheduleDayOfWeek :: WeekDay
                           , scheduleStart     :: TimeOfDay

src/Utils/Holidays.hs

@@ -10,6 +10,8 @@ module Utils.Holidays
   , feiertage
   , bankHolidays, bankHolidaysArea, bankHolidaysAreaSet
   , isBankHoliday, isBankHolidayArea 
+  , isWeekend
+  , addBusinessDays
   ) where
 
 import Import.NoModel
@@ -107,13 +109,16 @@ isBankHolidayArea land dd = dd `Set.member` holidays
 -- | Returns whether a day is a bank holiday for years >= 1995
 -- | Repeated calls are handled efficiently using lazy memoization 
 isBankHolidayArea :: Feiertagsgebiet -> Day -> Bool
-isBankHolidayArea land dd = dd `Set.member` holidays
+isBankHolidayArea land = ibha
   where 
-    (year, _, _) = toGregorian dd
+    landHoliday = Map.lookup land memoHolidays 
-    holidays 
+    ibha dd     = dd `Set.member` holidays
-      | (Just hys) <- Map.lookup land memoHolidays
+      where 
-      , (Just hds) <- index hys $ fromInteger $ year2index year = hds
+        (year, _, _) = toGregorian dd
-      | otherwise = bankHolidaysAreaSet land year 
+        holidays 
+          | (Just hys) <- landHoliday
+          , (Just hds) <- index hys $ fromInteger $ year2index year = hds
+          | otherwise = bankHolidaysAreaSet land year 
 
 -- memoize holidays 
 memoHolidays :: Map.Map Feiertagsgebiet [Set.Set Day]
@@ -137,3 +142,27 @@ index2year y = result
     (x,r) = y `divMod` 2 
     result | r == 0    = memoTip + x 
            | otherwise = memoTip - x - 1
+
+-- | Test for Saturday/Sunday 
+isWeekend :: Day -> Bool
+isWeekend = isWeekend' . dayOfWeek 
+  where 
+    isWeekend' :: WeekDay -> Bool
+    isWeekend' Sunday   = True 
+    isWeekend' Saturday = True 
+    isWeekend' _        = False
+
+-- | Always returns a business day. 
+-- | Saturday/Sunday/Holiday treated like next (n>=0) or previous (n<0) working day
+addBusinessDays :: Feiertagsgebiet -> Integer -> Day -> Day
+addBusinessDays land = abd 
+  where 
+    ibhal        = isBankHolidayArea land 
+    freeday   dd = isWeekend dd || ibhal dd 
+    abd n = abd' n
+      where         
+        (fwd, bwd)  | n >= 0    = (succ, pred)
+                    | otherwise = (pred, succ)
+        abd' m dd | freeday dd = abd'      m  (fwd dd)              
+                  | m == 0     =                   dd
+                  | otherwise  = abd' (bwd m) (fwd dd)

test/Model/TypesSpec.hs

@@ -46,20 +46,26 @@ import qualified Data.Text.Lazy as LT
 
 import Text.Blaze.Html.Renderer.Text (renderHtml)
 
+import Handler.Utils.DateTime (getYear)
 
+{-
+instance Arbitrary Day where
+    arbitrary = ModifiedJulianDay <$> choose (-313698, 2973483) -- 1000-01-1 to 9999-12-31
+    -- arbitrary = ModifiedJulianDay <$> choose (15020, 2973483) -- 1900-01-1 to 9999-12-31
+    shrink day = let
+        (y, m, d) = toGregorian day
+        dayShrink   = [fromGregorian y m (d - 1) | d > 1]
+        monthShrink = [fromGregorian y (m - 1) d | m > 1]            
+        yearShrink  = [fromGregorian (y - 1) m d | y > 2000] 
+        in dayShrink ++ monthShrink ++ yearShrink
 
-instance Arbitrary Season where
+instance CoArbitrary Day where
-  arbitrary = genericArbitrary
+    coarbitrary (ModifiedJulianDay d) = coarbitrary d
-  shrink = genericShrink
+-}
-instance CoArbitrary Season
-instance Function Season
 
 instance Arbitrary TermIdentifier where
-  arbitrary = do
+  arbitrary = TermIdentifier <$> arbitrary    
-    season <- arbitrary
+  shrink = fmap TermIdentifier . shrink . getTermDay 
-    year <- arbitrary `suchThat` (\y -> abs y >= 100)
-    return $ TermIdentifier{..}
-  shrink = filter ((\y -> abs y >= 100) . year) . genericShrink
 instance CoArbitrary TermIdentifier
 instance Function TermIdentifier
 
@@ -383,8 +389,6 @@ spec = do
       [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, finiteLaws, pathPieceLaws ]
     lawsCheckHspec (Proxy @Load)
       [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, commutativeSemigroupLaws, commutativeMonoidLaws ]
-    lawsCheckHspec (Proxy @Season)
-      [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws ]
     lawsCheckHspec (Proxy @TermIdentifier)
       [ eqLaws, showReadLaws, ordLaws, enumLaws, persistFieldLaws, jsonLaws, httpApiDataLaws, pathPieceLaws ]
     lawsCheckHspec (Proxy @StudyFieldType)
@@ -460,14 +464,14 @@ spec = do
 
   describe "TermIdentifier" $ do
     it "has compatible encoding/decoding to/from Text" . property $
-      \term -> termFromText (termToText term) == Right term
+      \term -> termFromText (termToText term) == Right term      
-    it "works for some examples" . mapM_ termExample $
+    it "has compatible encoding/decoding to/from Rational" . property $
-      [ (TermIdentifier 2017 Q2, "17Q2")
-      , (TermIdentifier 1995 Q4, "95Q4")
-      , (TermIdentifier 3068 Q1, "3068Q1")
-      ]
-    it "has compatbile encoding/decoding to/from Rational" . property $
       \term -> termFromRational (termToRational term) == term
+    -- This is not sufficient
+    --it "has compatible encoding/decoding to/from PersistValue" . property $ 
+    --  \term -> fromPersistValue (toPersistValue term) == term
+    it "has human readable year encoding to Rational" . property $
+      \term -> truncate (termToRational term) == getYear (getTermDay term)
   describe "Pseudonym" $ do
     it "has sufficient vocabulary" $
       (length pseudonymWordlist ^ 2) `shouldSatisfy` (> (fromIntegral (maxBound :: Pseudonym) - fromIntegral (minBound :: Pseudonym)))