chore(term): change to 4 digit format for disambiguation

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

@@ -5,24 +5,23 @@ TermStartMustBeBeforeLectureStart: Semester muss vor der Vorlesungszeit beginnen
 TermEndMustBeAfterLectureEnd: Vorlesungszeit muss vor dem Semester enden.
 TermShort: Kürzel
 TermCourseCount: Kurse
-TermStart: Semesteranfang
+TermStart: Anfang Kursperiode
-TermEnd: Semesterende
+TermEnd: Ende Kursperiode
-LectureStart: Beginn Vorlesungen
+LectureStart: Beginn Kurse
 TermEdited  tid@TermId: Semester #{tid} erfolgreich editiert.
 TermNewTitle: Semester editieren/anlegen.
 InvalidInput: Eingaben bitte korrigieren.
 Term !ident-ok: Semester
 TermPlaceholder: JJJJ-MM-TT (Erster Tag einer Schulung)
 TermStartDay: Erster Tag
-TermStartDayTooltip: Üblicherweise immer 1. April oder 1. Oktober
 TermEndDay: Letzter Tag
-TermEndDayTooltip: Üblicherweise immer 30. September oder 31. März
 TermHolidays: Feiertage
 TermHolidayPlaceholder: Feiertag
 TermHolidayMissing: Feiertag wird benötigt
 TermLectureStart: Beginn Vorlesungen
 TermLectureEnd: Ende Vorlesungen
-TermLectureEndTooltip: Meistens dauer das Sommersemester 14 Wochen und das Wintersemester 15 Wochen.
+TermLectureStartTooltip: Muss am oder nach dem Beginn liegen
+TermLectureEndTooltip: Muss am oder vor dem Ende liegen
 TermActive: Aktiv
 NumCourses num@Int64: #{num} #{pluralDE num "Kurs" "Kurse"}
 TermsHeading: Semesterübersicht

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

@@ -5,24 +5,23 @@ TermStartMustBeBeforeLectureStart: Semester start must be before lecture start.
 TermEndMustBeAfterLectureEnd: Lecture end must be before semester end.
 TermShort: Shorthand
 TermCourseCount: Courses
-TermStart: Semester start
+TermStart: Start of teaching period
-TermEnd: Semester end
+TermEnd: End of teaching perios
-LectureStart: Lectures start
+LectureStart: Courses start
 TermEdited tid: Successfully edited semester #{tid}
 TermNewTitle: Edit/create semester
 InvalidInput: Invalid input
 Term: Semester
 TermPlaceholder: YYYY-MM-DD (First day of courses)
 TermStartDay: Starting day
-TermStartDayTooltip: Usually 1st of April or 1st of October
 TermEndDay: Last day
-TermEndDayTooltip: Usually 30th of September or 31st of March
 TermHolidays: Legal holidays
 TermHolidayPlaceholder: Legal holiday
 TermHolidayMissing: Holiday is required
 TermLectureStart: Lectures start
 TermLectureEnd: Lectures end
-TermLectureEndTooltip: Summer semesters are usually 14 weeks; winter semesters 15
+TermLectureStartTooltip: Must be on or after starting day 
+TermLectureEndTooltip: Must be before or on ending day 
 TermActive: Active
 NumCourses num: #{num} #{pluralEN num "course" "courses"}
 TermsHeading: Semesters

models/lms.model

@@ -21,13 +21,14 @@ Qualification
 --    A: Es kann gleich eine LMS Pin generiert und verschickt werden!
 --  - Aufteilung Qualification "R" in zwei Teile: "R e-learning" und "R praxis" okay? 
 
--- Fragen an Know-How:
+-- Besonderheiten:
---  - Bedeutung LMS Übermittlung interner Mitarbeiter?
+--  - LmsIdent muss für alle Qualificationen einzigartig sein!
---  - LmsUser shall submit DELTA only: Beware, GET Request will always return the same; until POST Request was processed!
+--  - Durchfallen wird mit UserList ständig erneut gesandt, bis Löschantrag gestellt wurde.
---  - Success/Failure: is an explicit LMS-delete still necessary?
+--  - Bestehen mit Result wird nur ein einziges mal gesendet! (Ausfallrisiko: keine Bestätigung der Kommunikation!)
---  - User: pin reset = 1 to existing pin problematic? Resubmission of existing users with pin causes which problems?
+--  - Explizites Löschen eines LmsIdent nach Success/Failure ist notwendig (feedback bei Block)
---  - ident unique for all qualifications F/R or duplicated? (F/R refreshers might be simultaneous)
+--  - LmsUser soll nur DELTA übermitteln. (GET Request will always return the same; until POST Request was processed!)
---  - Anzahl Fehlversuche: wird pro Durchfallen ein Failed gemeldet oder nur einmal?
+--  - PinReset==1 mit bestehendem Passwort kann problemlos erneut gesendet werden
+--  - Flag "interner Mitarbeiter" wird von Know-How ignoriert / nicht ausgewertet (legacy)
 
 QualificationPrecondition
   qualification     QualificationId             -- AND: not unique, ie. qualification can have multiple required preconditions
@@ -46,7 +47,7 @@ QualificationEdit
 QualificationUser
   user              UserId
   qualification     QualificationId OnDeleteCascade OnUpdateCascade
-  validUntil        UTCTime
+  validUntil        UTCTime --TODO convert to DAYS only!
   lastRefresh       UTCTime                     -- lastRefresh > validUntil possible, if Qualification^elearningOnly == False
   firstHeld         UTCTime                     -- first time the qualification was earned, should never change
   -- temporärer Entzug vorsehen
@@ -95,6 +96,7 @@ LmsUser
   started           UTCTime       default=now()
   received          UTCTime Maybe               -- last acknowledgement by LMS 
   ended             UTCTime Maybe               -- ident was deleted from LMS 
+  -- Primary ident -- newtype Key LmsUserId = LmsUserKey { unLmsUser :: Text } -- change LmsIdent -> Text. Do we want this?
   UniqueLmsUser ident -- idents must be unique accross all qualifications, since idents are global within LMS!
   deriving Generic
 

src/Handler/Term.hs

@@ -354,11 +354,11 @@ newTermForm mtid template = validateForm validateTerm $ \html -> do
           fRequired = False
     flip (renderAForm FormStandard) html $ TermForm
       <$> tidForm
-      <*> areq dayField  (fslI MsgTermStartDay & setTooltip MsgTermStartDayTooltip) (tftStart template)
+      <*> areq dayField  (fslI MsgTermStartDay) (tftStart template)
-      <*> areq dayField  (fslI MsgTermEndDay   & setTooltip MsgTermEndDayTooltip)   (tftEnd   template)
+      <*> areq dayField  (fslI MsgTermEndDay  )   (tftEnd   template)
       <*> (ungroupHolidays <$> holidayForm (groupHolidays <$> tftHolidays template))
-      <*> areq dayField  (fslI MsgTermLectureStart) (tftLectureStart template)
+      <*> areq dayField  (fslI MsgTermLectureStart & setTooltip MsgTermLectureStartTooltip) (tftLectureStart template)
-      <*> areq dayField  (fslI MsgTermLectureEnd & setTooltip MsgTermLectureEndTooltip) (tftLectureEnd template)
+      <*> areq dayField  (fslI MsgTermLectureEnd   & setTooltip MsgTermLectureEndTooltip)   (tftLectureEnd template)
       <*> activeForm (tftActive template)
 
 

src/Handler/Utils/DateTime.hs

@@ -12,7 +12,7 @@ module Handler.Utils.DateTime
   , getTimeLocale, getDateTimeFormat
   , getDateTimeFormatter
   , validDateTimeFormats, dateTimeFormatOptions
-  , addLocalDays
+  , addLocalDays, addDiffDays
   , addOneWeek, addWeeks
   , weeksToAdd
   , setYear, getYear
@@ -249,6 +249,10 @@ addLocalDays n utct = localTimeToUTCTZ appTZ newLocal
     newDay   = addDays n oldDay
     newLocal = oldLocal { localDay = newDay }
 
+addDiffDays :: CalendarDiffDays -> UTCTime -> UTCTime
+addDiffDays = over _utctDay . addGregorianDurationClip
+
+
 weeksToAdd :: UTCTime -> UTCTime -> Integer
 -- ^ Number of weeks needed to add so that first
 --   time occurs later than second time

src/Jobs/Handler/LMS.hs

@@ -1,7 +1,9 @@
 {-# LANGUAGE TypeApplications #-}
 
 module Jobs.Handler.LMS 
-  ( dispatchJobLmsResults
+  ( dispatchJobLmsEnqueue
+  , dispatchJobLmsDequeue
+  , dispatchJobLmsResults
   , dispatchJobLmsUserlist
   ) where 
 
@@ -13,6 +15,47 @@ import qualified Database.Esqueleto.Experimental as E
 -- import qualified Database.Esqueleto.PostgreSQL as E -- for insertSelect variant
 import qualified Database.Esqueleto.Utils as E
 
+import Handler.Utils.DateTime (addDiffDays)
+
+dispatchJobLmsEnqueue :: QualificationId -> JobHandler UniWorX
+dispatchJobLmsEnqueue qid = JobHandlerAtomic act
+  where 
+    -- act :: YesodJobDB UniWorX ()
+    act = hoist lift $ do      
+      now <- liftIO getCurrentTime
+      Just (Entity _ quali) <- E.selectOne $ E.from $ \quali -> E.where_ (quali E.^. QualificationId E.==. E.val qid) >> pure quali
+      -- Just quali <- get qid 
+      let Just refreshTime = qualificationRefreshWithin quali -- HACK / TODO
+          freshIdent = LmsIdent "abcd" -- TODO
+          freshPin   = "1234" -- TODO
+          cutoff     = addDiffDays refreshTime now
+      res <- E.insertSelect $ do 
+        quser <- from (E.table @QualificationUser)
+        E.where_ (  quser E.^. QualificationUserQualification E.==. E.val qid 
+              E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val now 
+              E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val cutoff
+          )
+              -- and not exists already as LMS User
+        return $ LmsUser 
+          E.<# E.val qid 
+          E.<&> (quser E.^. QualificationUserUser)               
+          E.<&> E.val freshIdent -- ident     -- THIS IS A PROBLEM! MUST ALSO BE UNIQUE!
+          E.<&> E.val freshPin   -- pin       -- THIS IS A PROBLEM!
+          E.<&> E.false          -- reset
+          E.<&> E.nothing        -- status
+          E.<&> E.val now        -- started
+          E.<&> E.nothing        -- received 
+          E.<&> E.nothing        -- ended 
+
+      -- find qualification holders
+      error "lms dequeu stub"
+
+dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX
+dispatchJobLmsDequeue qid = 
+  -- wenn bestanden: qualification verlängern & LmsIdent löschen
+  -- wenn durchgefallen: LmsIdent löschen
+  -- wenn Zeit abgelaufen: LmsIdent löschen 
+  error "lms dequeu stub"
 
 dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX
 dispatchJobLmsResults qid = JobHandlerAtomic act 

src/Jobs/Types.hs

@@ -105,6 +105,8 @@ data Job
                                      , jEpoch
                                      , jIteration :: Natural
                                      }
+  | JobLmsEnqueue  { jQualification :: QualificationId }
+  | JobLmsDequeue  { jQualification :: QualificationId }
   | JobLmsUserlist { jQualification :: QualificationId }
   | JobLmsResults  { jQualification :: QualificationId }
   deriving (Eq, Ord, Show, Read, Generic, Typeable)

src/Model/Types/DateTime.hs

@@ -71,12 +71,14 @@ shortened = iso shorten expand
 --   Handler.Utils.Widget.tidFromText
 --   MsgTermPlaceHolder
 termToText :: TermIdentifier -> Text
-termToText TermIdentifier{..} = Text.pack . show $ year ^. shortened
+termToText TermIdentifier{..} = Text.pack . show $ year -- ^. shortened
 
 termFromText :: Text -> Either Text TermIdentifier
 termFromText t
-  | Just (review shortened -> year) <- readMaybe $ Text.unpack t
+  | Just year <- readMaybe $ Text.unpack t
   = Right TermIdentifier {..}
+  -- | Just (review shortened -> year) <- readMaybe $ Text.unpack t
+  -- = Right TermIdentifier {..}
   | otherwise 
   = Left $ "Invalid TermIdentifier: “" <> t <> "”; expected is just a year number." 
   

test/Model/TypesSpec.hs

@@ -46,7 +46,6 @@ import qualified Data.Text.Lazy as LT
 
 import Text.Blaze.Html.Renderer.Text (renderHtml)
 
-import Handler.Utils.DateTime (getYear)
 
 {-
 instance Arbitrary Day where
@@ -65,7 +64,7 @@ instance CoArbitrary Day where
 
 instance Arbitrary TermIdentifier where
   arbitrary = TermIdentifier <$> arbitrary    
-  shrink = fmap TermIdentifier . shrink . getTermDay 
+  shrink = fmap TermIdentifier . shrink . year
 instance CoArbitrary TermIdentifier
 instance Function TermIdentifier
 
@@ -471,7 +470,7 @@ spec = do
     --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)
+      \term -> truncate (termToRational term) == year term
   describe "Pseudonym" $ do
     it "has sufficient vocabulary" $
       (length pseudonymWordlist ^ 2) `shouldSatisfy` (> (fromIntegral (maxBound :: Pseudonym) - fromIntegral (minBound :: Pseudonym)))