Merge branch 'master' into fradrive/fraport-corporate-design

.gitlab-ci.yml

@@ -2,12 +2,12 @@
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
-workflow:
+# workflow:
-  rules:
+#   rules:
-    - if: $CI_COMMIT_BRANCH == $CI_DEFAULT_BRANCH
+#     - if: $CI_COMMIT_BRANCH == $CI_DEFAULT_BRANCH
-    - if: $CI_MERGE_REQUEST_ID
+#     - if: $CI_MERGE_REQUEST_ID
-    - if: $CI_COMMIT_TAG =~ /^v/
+#     - if: $CI_COMMIT_TAG =~ /^v/
-    - if: $CI_COMMIT_TAG =~ /^t/
+#     - if: $CI_COMMIT_TAG =~ /^t/
 
 default:
   image:

CHANGELOG.md

@@ -2,6 +2,35 @@
 
 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
 
+## [27.4.45](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.44...v27.4.45) (2023-10-18)
+
+
+### Bug Fixes
+
+* **hoogle:** remove erroneous comment ([c011d88](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c011d887cece8338920355b540aa4b233e0b994f))
+* **sap:** yet another fix for finding date intervals ([fde97b0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fde97b048ab04ab59c9e3f2a2f74bb2c1e996b22))
+
+## [27.4.44](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.43...v27.4.44) (2023-10-18)
+
+
+### Bug Fixes
+
+* **sap:** combine immediate next day licence chnages for SAP ([f4adfdf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f4adfdf87270930d4ca6611f2a9956613fcace53))
+* **sap:** combine immediate next day licence chnages for SAP ([cbb44f1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cbb44f106ad59e0a53ca04963ade5544120b7e21))
+* **sap:** combineBlocks yet another bug squashed ([3924d14](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3924d14abd868305b42c9d04913536b4999dc45b))
+* **sap:** compileBlocks ([b4a88ab](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b4a88abcf85783c350ad2bf3a5e973d13d1eb1f6))
+
+## [27.4.43](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.42...v27.4.43) (2023-10-13)
+
+## [27.4.42](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.41...v27.4.42) (2023-10-12)
+
+
+### Bug Fixes
+
+* **build:** Update ParticipantInvite.hs ([f888da3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f888da3ab0df45bb3c515ebb7cbb43569fdaa1fa))
+* **build:** Update ParticipantInvite.hs ([fa4f9b2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fa4f9b24475261afc1e534541c8878a85e6a1b10))
+* **build:** Update Utils.hs ([87f0b2e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/87f0b2edab2bcf696b7b776e47272ef2204c0b75))
+
 ## [27.4.41](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.40...v27.4.41) (2023-10-04)
 
 

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

@@ -94,6 +94,7 @@ UserHijack: Sitzung übernehmen
 UserAddSupervisor: Ansprechpartner hinzufügen
 UserSetSupervisor: Ansprechpartner ersetzen
 UserRemoveSupervisor: Alle Ansprechpartner entfernen
+UserIsSupervisor: Ist Ansprechpartner
 AuthKindLDAP: Fraport AG Kennung
 AuthKindPWHash: FRADrive Kennung
 AuthKindNoLogin: Kein Login möglich

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

@@ -94,6 +94,7 @@ UserHijack: Hijack session
 UserAddSupervisor: Add supervisor
 UserSetSupervisor: Replace supervisors
 UserRemoveSupervisor: Set to unsupervised
+UserIsSupervisor: Is supervisor
 AuthKindLDAP: Fraport AG account
 AuthKindPWHash: FRADrive account
 AuthKindNoLogin: No login

messages/uniworx/utils/table_column/de-de-formal.msg

@@ -16,7 +16,7 @@ TableTerm !ident-ok: Jahr
 TableCourseSchool: Bereich
 TableSubmissionGroup: Feste Abgabegruppe
 TableNoSubmissionGroup: Keine feste Abgabegruppe
-TableMatrikelNr: AVS Nr
+TableMatrikelNr: AVS Personennummer
 TableSex: Geschlecht
 TableBirthday: Geburtsdatum
 TableSchool: Bereich

messages/uniworx/utils/table_column/en-eu.msg

@@ -16,7 +16,7 @@ TableTerm: Year
 TableCourseSchool: Department
 TableSubmissionGroup: Registered submission group
 TableNoSubmissionGroup: No registered submission group
-TableMatrikelNr: AVS No
+TableMatrikelNr: AVS person no
 TableSex: Sex
 TableBirthday: Birthday
 TableSchool: Department

nix/docker/version.json

@@ -1,3 +1,3 @@
 {
-  "version": "27.4.41"
+  "version": "27.4.45"
 }

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "27.4.41",
+  "version": "27.4.45",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "27.4.41",
+  "version": "27.4.45",
   "description": "",
   "keywords": [],
   "author": "",

package.yaml

@@ -1,5 +1,5 @@
 name: uniworx
-version: 27.4.41
+version: 27.4.45
 dependencies:
   - base
   - yesod

src/Audit/Types.hs

@@ -212,7 +212,7 @@ data Transaction
     }
   | TransactionQualificationUserEdit  -- Note that a renewal always entails unblocking as well!
     { transactionUser                         :: UserId                 -- qualification holder that is updated
-    , transactionQualificationUser            :: QualificationUserId  -- könnte entfernt werden
+    , transactionQualificationUser            :: QualificationUserId    -- not really necessary, maybe remove?
     , transactionQualification                :: QualificationId    
     , transactionQualificationValidUntil      :: Day
     , transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration)
@@ -226,7 +226,12 @@ data Transaction
     { transactionUser               :: UserId                         -- qualification holder that is updated
       -- , transactionQualificationUser  :: QualificationUserId       -- not neccessary due to UniqueQualificationUser
     , transactionQualification      :: QualificationId
-    , transactionQualificationBlock :: QualificationUserBlock         -- TODO -- 
+    , transactionQualificationBlock :: QualificationUserBlock         -- full information about block
+    }
+  | TransactionQualificationUserScheduleRenewal
+    { transactionUser                         :: UserId               -- qualification holder that is updated
+    , transactionQualification                :: QualificationId
+    , transactionQualificationScheduleRenewal :: Maybe Bool           -- TRUE=will be notified upon expiry, FALSE=won't be notified; always JUST, for compatibility with TransactionQualificationUserEdit
     }
   deriving (Eq, Ord, Read, Show, Generic)
 

src/Database/Esqueleto/Utils.hs

@@ -24,7 +24,7 @@ module Database.Esqueleto.Utils
   , mkContainsFilter, mkContainsFilterWith
   , mkContainsFilterWithSet, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus
   , mkDayFilter, mkDayFilterFrom, mkDayFilterTo
-  , mkExistsFilter
+  , mkExistsFilter, mkExistsFilterWithComma
   , anyFilter, allFilter
   , ascNullsFirst, descNullsLast
   , orderByList
@@ -45,7 +45,7 @@ module Database.Esqueleto.Utils
   , unKey
   , selectCountRows, selectCountDistinct
   , selectMaybe
-  , day, day', interval, diffDays, diffTimes
+  , day, day', dayMaybe, interval, diffDays, diffTimes
   , exprLift
   , explicitUnsafeCoerceSqlExprValue
   , module Database.Esqueleto.Utils.TH
@@ -421,6 +421,17 @@ mkExistsFilter query row criterias
   | Set.null criterias = true
   | otherwise = any (E.exists . query row) $ Set.toList criterias
 
+mkExistsFilterWithComma :: PathPiece a
+               => (Text -> a)
+               -> (t -> a -> E.SqlQuery ())
+               -> t
+               -> Set.Set Text
+               -> E.SqlExpr (E.Value Bool)
+mkExistsFilterWithComma cast query row (foldMap commaSeparatedText -> criterias)
+  | Set.null criterias = true
+  | otherwise = any (E.exists . query row) (cast <$> Set.toList criterias)
+
+
 -- | Combine several filters, using logical or
 anyFilter :: Foldable f
           => f (t -> cs -> E.SqlExpr (E.Value Bool))
@@ -656,6 +667,9 @@ day = E.unsafeSqlCastAs "date"
 day' :: E.SqlExpr (E.Value Text) -> E.SqlExpr (E.Value Day)
 day' = E.unsafeSqlCastAs "date"
 
+dayMaybe :: E.SqlExpr (E.Value (Maybe UTCTime)) -> E.SqlExpr (E.Value (Maybe Day))
+dayMaybe = E.unsafeSqlCastAs "date"
+
 interval :: CalendarDiffDays -> E.SqlExpr (E.Value Day) -- E.+=.  requires both types to be the same, so we use Day
 -- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example 
 interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text.Builder.fromString . iso8601Show

src/Handler/Admin/Avs.hs

@@ -431,8 +431,7 @@ getProblemAvsSynchR = do
           <*> mkLicenceTable apidStatus "avsLicDiffGrantRollfeld"  AvsNoLicence        avsLicenceDiffGrantRollfeld
 
   now <- liftIO getCurrentTime
-  let nowaday = utctDay now
+  let procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
-      procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
       procRes aLic (LicenceTableChangeAvsData       , apids) = do
         oks <- catchAllAvs $ setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids
         let no_req = Set.size apids
@@ -458,7 +457,7 @@ getProblemAvsSynchR = do
           uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
           -- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG
           void $ qualificationUserBlocking licenceTableChangeFDriveQId uids True Nothing (Left licenceTableChangeFDriveReason) False
-          forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew
+          forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId now licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew "Admin Resolution"
           (length uids,) <$> get404 licenceTableChangeFDriveQId
         addMessageI (bool Success Warning $ null apids) $ MsgSetFraDriveLicences (citext2string qualificationShorthand) n
         redirect ProblemAvsSynchR -- must be outside runDB

src/Handler/Admin/Crontab.hs

@@ -220,5 +220,5 @@ postAdminJobsR = do
   
     getJobName :: Value -> Maybe Text
     getJobName (Object o) 
-      | Just (String s) <- HashMap.lookup "job" o = Just s -- $ kebabToCamel s
+      | Just (String s) <- HashMap.lookup "job" o = Just s --  (kebabToCamel s)
     getJobName _ = Nothing

src/Handler/Course/ParticipantInvite.hs

@@ -49,11 +49,19 @@ tutorialTemplateNames Nothing     = ["Vorlage", "Template"]
 tutorialTemplateNames (Just name) = [prefixes <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- [mempty, tutorialTypeSeparator <> name]]
 
 tutorialDefaultName :: Maybe TutorialType -> Day -> TutorialName
-tutorialDefaultName Nothing     = CI.mk . tshow  -- Don't use user date display setting, so that tutorial default names conform to all users
+tutorialDefaultName Nothing     = formatDayForTutName 
 tutorialDefaultName (Just ttyp) = 
   let prefix = CI.mk $ snd $ Text.breakOnEnd (CI.original tutorialTypeSeparator) $ CI.original ttyp
   in  (<> (tutorialTypeSeparator <> prefix)) . tutorialDefaultName Nothing
 
+formatDayForTutName :: Day -> CI Text -- "%yy_%mm_%dd" -- Do not use user date display setting, since tutorial default names must be universal regardless of user
+-- formatDayForTutName = CI.mk . formatTime' "%y_%m_%d" -- we don't want to go monadic for this
+formatDayForTutName = CI.mk . Text.map d2u . Text.drop 2 . tshow 
+  where 
+    d2u '-' = '_'
+    d2u  c  =  c
+
+
 data ButtonCourseRegisterMode = BtnCourseRegisterConfirm | BtnCourseRegisterAbort
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
 instance Universe ButtonCourseRegisterMode

src/Handler/LMS.hs

@@ -424,7 +424,7 @@ lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.Left
                     E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
                         E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser))
                     let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on!
-                    pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated     ) pjOrder, -- return two aggregates only works with select, the restricted typr of subSelect does not seem to support this!
+                    pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated     ) pjOrder, -- return two aggregates only works with select, the restricted type of subSelect does not seem to support this!
                            E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder                                                        
     return (qualUser, user, lmsUser, qualBlock, printAcknowledged, validQualification now qualUser)
 
@@ -739,7 +739,7 @@ postLmsR sid qsh = do
             , QualificationUserUser <-. usersList            
             , QualificationUserValidUntil <. cutoff
             ] []          
-          forM_ shortUsers $ upsertQualificationUser qid nowaday cutoff Nothing
+          forM_ shortUsers $ upsertQualificationUser qid now cutoff Nothing "E-Learning Reset"
 
         fromIntegral <$> (if isReset
             then updateWhereCount ([LmsUserQualification ==. qid, LmsUserUser <-. usersList, LmsUserResetTries ==. False, LmsUserEnded ==. Nothing] -- , LmsUserLocked ==. True] -- needs to be locked for reset, but this is counter-intuitive for users; should be harmles, but delays reset until lock is effective

src/Handler/PrintCenter.hs

@@ -225,9 +225,9 @@ mkPJTable = do
     dbtFilter = mconcat
       [ single ("name"         , FilterColumn . E.mkContainsFilterWithCommaPlus id                $ views (to queryPrintJob)      (E.^. PrintJobName))
       , single ("apcid"        , FilterColumn . E.mkContainsFilterWithComma     id                $ views (to queryPrintJob)      (E.^. PrintJobApcIdent))
-      , single ("filename"     , FilterColumn . E.mkContainsFilter                            $ views (to queryPrintJob)      (E.^. PrintJobFilename))      
+      , single ("filename"     , FilterColumn . E.mkContainsFilter                                $ views (to queryPrintJob)      (E.^. PrintJobFilename))      
-      , single ("created"      , FilterColumn . E.mkDayFilter                                 $ views (to queryPrintJob)      (E.^. PrintJobCreated))
+      , single ("created"      , FilterColumn . E.mkDayFilter                                     $ views (to queryPrintJob)      (E.^. PrintJobCreated))
-      --, single ("created"      , FilterColumn . E.mkDayBetweenFilter                        $ views (to queryPrintJob)      (E.^. PrintJobCreated))
+      --, single ("created"      , FilterColumn . E.mkDayBetweenFilter                            $ views (to queryPrintJob)      (E.^. PrintJobCreated))
       , single ("recipient"    , FilterColumn . E.mkContainsFilterWithCommaPlus Just              $ views (to queryRecipient)     (E.?. UserDisplayName))
       , single ("sender"       , FilterColumn . E.mkContainsFilterWithCommaPlus Just              $ views (to querySender)        (E.?. UserDisplayName))
       , single ("course"       , FilterColumn . E.mkContainsFilterWith          (Just . CI.mk)    $ views (to queryCourse)        (E.?. CourseName))

src/Handler/Profile.hs

@@ -102,7 +102,6 @@ instance RenderMessage UniWorX NotificationTriggerKind where
     where
       mr = renderMessage f ls
 
-
 makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
 makeSettingForm template html = do
     MsgRenderer mr <- getMsgRenderer
@@ -169,7 +168,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar
 notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings
 notificationForm template = wFormToAForm $ do
   mbUid <- liftHandler maybeAuthId
-  isAdmin <- lift . lift $ hasReadAccessTo AdminR
+  isAdmin <- checkAdmin
 
   let
     sectionIsHidden :: NotificationTriggerKind -> DB Bool
@@ -370,13 +369,13 @@ validateSettings User{..} = do
 
   userPrefersPostal' <- use _stgPrefersPostal
   guardValidation MsgUserPrefersPostalInvalid $
-    not $ userPrefersPostal' && postalNotSet
+    not $ userPrefersPostal' && (postalNotSet || isJust userCompanyDepartment)
 
   userPinPassword'  <- use _stgPinPassword
   let pinBad     = validCmdArgument =<< userPinPassword'
       pinMinChar = 5
       pinLength  = maybe 0 length userPinPassword'
-  pinOk <- if userPrefersPostal' || pinMinChar <= pinLength then pure True else liftHandler $ hasReadAccessTo AdminR -- admins are allowed to ignore pin requirements
+  pinOk <- if userPrefersPostal' || pinMinChar <= pinLength then pure True else checkAdmin -- admins are allowed to ignore pin requirements
   whenIsJust pinBad (tellValidationError . MsgPDFPasswordInvalid) -- used as CMD argument for pdftk
   guardValidation (MsgPDFPasswordTooShort pinMinChar) pinOk
 
@@ -450,9 +449,12 @@ serveProfileR (uid, user@User{..}) = do
 
   formResult res $ \SettingsForm{..} -> do
     now <- liftIO getCurrentTime
+    isAdmin <- checkAdmin
+    thisUser <- fromMaybe uid <$> maybeAuthId
+    let changeEmailByUser = userDisplayEmail /= stgDisplayEmail && (not isAdmin || thisUser == uid)
     runDBJobs $ do
       update uid $
-        [ UserDisplayEmail         =. stgDisplayEmail   | userDisplayEmail  == stgDisplayEmail  ] ++ -- Note that DisplayEmail changes must be confirmed, see 472
+        [ UserDisplayEmail         =. stgDisplayEmail   | not changeEmailByUser                 ] ++ -- DisplayEmail changes by Users must be confirmed, see 480 below
         [ UserPostLastUpdate       =. Just now          | userPostAddress   /= stgPostAddress   ] ++
         [ UserDisplayName          =. stgDisplayName
         , UserMaxFavourites        =. stgMaxFavourites
@@ -472,7 +474,7 @@ serveProfileR (uid, user@User{..}) = do
         , UserExamOfficeGetLabels  =. (stgExamOfficeSettings & eosettingsGetLabels)
         ]
       updateFavourites Nothing
-      when (stgDisplayEmail /= userDisplayEmail) $ do
+      when changeEmailByUser $ do
         queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail
         addMessageI Info $ MsgUserDisplayEmailChangeSent stgDisplayEmail
       let

src/Handler/Qualification.hs

@@ -617,14 +617,20 @@ postQualificationR sid qsh = do
       addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
       reloadKeepGetParams $ QualificationR sid qsh
     (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do      
-      runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing
+      runDB . forM_ selectedUsers $ upsertQualificationUser qid now grantValidday Nothing "Admin"
       addMessageI  (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
       reloadKeepGetParams $ QualificationR sid qsh
     (action, selectedUsers) | isExpiryAct action -> do      
       let isUnexpire = action == QualificationActUnexpireData
-      upd <- runDB $ updateWhereCount
+      upd <- runDB $ do
-              [QualificationUserQualification ==. qid, QualificationUserUser <-. Set.toList selectedUsers]
+        forM_ selectedUsers $ \uid -> audit TransactionQualificationUserScheduleRenewal
-              [QualificationUserScheduleRenewal =. isUnexpire]
+          { transactionUser                         = uid
+          , transactionQualification                = qid
+          , transactionQualificationScheduleRenewal = Just isUnexpire
+          }
+        updateWhereCount
+          [QualificationUserQualification ==. qid, QualificationUserUser <-. Set.toList selectedUsers]
+          [QualificationUserScheduleRenewal =. isUnexpire]
       let msgKind = if upd > 0  then Success else Warning
           msgVal  = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire
       addMessageI msgKind msgVal

src/Handler/SAP.hs

@@ -6,6 +6,7 @@
 
 module Handler.SAP
   ( getQualificationSAPDirectR
+  , compileBlocks -- for Test in Handler.SAPSpec only
   )
   where
 
@@ -18,8 +19,9 @@ import Handler.Utils.Profile
 -- import qualified Data.CaseInsensitive as CI
 import qualified Data.Csv as Csv
 import           Database.Esqueleto.Experimental ((:&)(..))
-import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
+import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
 -- import qualified Database.Esqueleto.Legacy as E
+import qualified Database.Esqueleto.PostgreSQL as E
 import qualified Database.Esqueleto.Utils as E
 
 
@@ -55,22 +57,39 @@ instance ToNamedRecord SapUserTableCsv where
     ]
 
 -- | Removes all personalNummer which are not numbers between 10000 and 99999 (also excludes E-Accounts), which should not be returned by the query anyway (only qualfications with sap id and users with internal personnel number must be transmitted)
---   TODO: once temporary suspensions are implemented, a user must be transmitted to SAP in two rows: firstheld->suspensionFrom & suspensionTo->validTo
+--   temporary suspensions are transmitted to SAP in multiple rows: firstheld->suspension1, reinstate1->suspension2, reinstate2->validTo
-sapRes2csv :: [(Ex.Value (Maybe Text), Ex.Value Day, Ex.Value Day, Ex.Value (Maybe Text))] -> [SapUserTableCsv]
+sapRes2csv :: [(E.Value (Maybe Text), E.Value (Maybe Text), E.Value Day, E.Value Day, E.Value (Maybe [Maybe Day]), E.Value (Maybe [Maybe Bool]))] -> [SapUserTableCsv]
-sapRes2csv l = [ res | (Ex.Value pn@(Just persNo), Ex.Value firstHeld, Ex.Value validUntil, Ex.Value (Just sapId)) <- l 
+sapRes2csv = concatMap procRes
-                --  , let persNoAsInt = readMay =<< persNo -- also see Handler.Utils.Profile.validFraportPersonalNumber
+  where 
-                --  , persNoAsInt >= Just (10000::Int)       -- filter E-accounts for SAP export
+    procRes (E.Value pn@(Just persNo), E.Value (Just sapId), E.Value firstHeld, E.Value validUntil, E.Value (fromMaybe [] -> qubFroms), E.Value (fromMaybe [] -> qubUnblocks))
-                --  , persNoAsInt <= Just (99999::Int)       -- filter E-accounts for SAP export                                                     
+      | validFraportPersonalNumber pn -- between 10000 and 99999 also see Handler.Utils.Profile.validFraportPersonalNumber
-                , let res = SapUserTableCsv
+        = let mkSap (dfrom,duntil) = SapUserTableCsv
-                            { csvSUTpersonalNummer = persNo
+                              { csvSUTpersonalNummer = persNo
-                            , csvSUTqualifikation  = sapId
+                              , csvSUTqualifikation  = sapId
-                            , csvSUTgültigVon      = firstHeld
+                              , csvSUTgültigVon      = dfrom
-                            , csvSUTgültigBis      = validUntil
+                              , csvSUTgültigBis      = duntil                            
-                            -- , csvSUTsupendiertBis  = blocked
+                              , csvSUTausprägung     = "J"
-                            , csvSUTausprägung     = "J"
+                              }
-                            }
+          in fmap mkSap $ compileBlocks firstHeld validUntil $ zipMaybes qubFroms qubUnblocks
-                , validFraportPersonalNumber pn
+    procRes _ = []
-               ]
+
+-- | compute a series of valid periods, assume that lists is already sorted by Day
+--   the lists encodes qualification_user_blocks with block=False/unblock=True 
+compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)]
+compileBlocks dStart dEnd = go (dStart, True) 
+  where 
+    go :: (Day,Bool) -> [(Day,Bool)] -> [(Day, Day)]
+    go (d,s) (p1@(d1,s1):r1@((d2,s2):r2))
+      | s1 == s2 && d <= d1                            = go (d,s) (p1:r2)   -- ignore unnecessary 2nd change      
+      | d1 == d2 || succ d1 == d2 || s == s1 || d > d1 = go (d,s)     r1    -- ignore unnecessary 1st change      
+    go (d,s) ((d1,s1):r1)
+      | dEnd <= d1        =          go (d ,s ) []                          -- remaining dates extend validity        
+      | s, not s1, d < d1 = (d,d1) : go (d1,s1) r1                          -- valid interval found
+      | s == s1           =          go (d ,s ) r1                          -- no change
+      | otherwise         =          go (d1,s1) r1                          -- ignore invalid interval
+    go (d,s) []
+      | s         = [(d,dEnd)]
+      | otherwise = []
 
 -- | Deliver all employess with a successful LDAP synch within the last 3 months
 getQualificationSAPDirectR :: Handler TypedContent
@@ -78,23 +97,36 @@ getQualificationSAPDirectR = do
   now   <- liftIO getCurrentTime  
   fdate <- formatTime' "%Y%m%d_%H-%M" now 
   let ldap_cutoff = addDiffDaysRollOver (fromMonths $ -3) now
-  qualUsers <- runDB $ Ex.select $ do
+  qualUsers <- runDB $ E.select $ do
-    (qual :& qualUser :& user) <- 
+    (qual :& qualUser :& user :& qualBlock) <- 
-      Ex.from $ Ex.table @Qualification 
+      E.from $ E.table @Qualification 
-      `Ex.innerJoin` Ex.table @QualificationUser
+      `E.innerJoin` E.table @QualificationUser
-      `Ex.on` (\(qual :& qualUser) -> qual Ex.^. QualificationId Ex.==. qualUser Ex.^. QualificationUserQualification)
+      `E.on` (\(qual :& qualUser) -> qual E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification)
-      `Ex.innerJoin` Ex.table @User
+      `E.innerJoin` E.table @User
-      `Ex.on` (\(_ :& qualUser :& user) -> qualUser Ex.^. QualificationUserUser Ex.==. user Ex.^. UserId)
+      `E.on` (\(_ :& qualUser :& user) -> qualUser E.^. QualificationUserUser E.==. user E.^. UserId)
-    Ex.where_ $ E.isJust (qual Ex.^. QualificationSapId)
+      `E.leftJoin` E.table @QualificationUserBlock
-        Ex.&&.  E.isJust (user Ex.^. UserCompanyPersonalNumber)
+      `E.on` (\(_ :& qualUser :& _ :& qualBlock) -> 
-        Ex.&&.  E.isJust (user Ex.^. UserLastLdapSynchronisation)
+                  qualUser E.^. QualificationUserId E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
-        Ex.&&.  (E.justVal ldap_cutoff Ex.<=. user Ex.^. UserLastLdapSynchronisation)
+          E.&&.   E.val now                         E.>~. qualBlock E.?. QualificationUserBlockFrom
+        )
+    E.where_ $ E.isJust (qual E.^. QualificationSapId)
+        E.&&.  E.isJust (user E.^. UserCompanyPersonalNumber)
+        E.&&.  E.isJust (user E.^. UserLastLdapSynchronisation)
+        E.&&.  (E.justVal ldap_cutoff E.<=. user E.^. UserLastLdapSynchronisation)
+    E.groupBy ( user      E.^. UserCompanyPersonalNumber
+              , qualUser  E.^. QualificationUserFirstHeld
+              , qualUser  E.^. QualificationUserValidUntil                
+              , qual      E.^. QualificationSapId
+              )
+    let blockOrder = [E.asc $ qualBlock E.?. QualificationUserBlockFrom, E.asc $ qualBlock E.?. QualificationUserBlockId]
+        -- blockAgg f = E.arrayAggWith E.AggModeAll (qualBlock E.^. f) blockOrder
     return 
-      ( user      Ex.^. UserCompanyPersonalNumber
+      ( user      E.^. UserCompanyPersonalNumber
-      , qualUser  Ex.^. QualificationUserFirstHeld
+      , qual      E.^. QualificationSapId
-      , qualUser  Ex.^. QualificationUserValidUntil
+      , qualUser  E.^. QualificationUserFirstHeld
-      -- , qualUser  Ex.^. QualificationUserBlockedDue
+      , qualUser  E.^. QualificationUserValidUntil
-      , qual      Ex.^. QualificationSapId
+      , E.arrayAggWith E.AggModeAll (E.dayMaybe $ qualBlock E.?. QualificationUserBlockFrom   ) blockOrder
+      , E.arrayAggWith E.AggModeAll (             qualBlock E.?. QualificationUserBlockUnblock) blockOrder
       )    
   let csvRendered = toCsvRendered sapUserTableCsvHeader $ sapRes2csv qualUsers
       fmtOpts = (review csvPreset CsvPresetRFC)

src/Handler/Tutorial/Users.hs

@@ -139,8 +139,9 @@ postTUsersR tid ssh csh tutn = do
     (TutorialUserGrantQualificationData{..}, selectedUsers)
       | tuQualification `Set.member` courseQids -> do
         -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
-        today <- utctDay <$> liftIO getCurrentTime
+        today <- liftIO getCurrentTime
-        runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing
+        let reason = "Kurs " <> CI.original (unSchoolKey ssh) <> "-" <> CI.original csh <> "-" <> CI.original tutn
+        runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing reason
         addMessageI  (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
         redirect $ CTutorialR tid ssh csh tutn TUsersR
     (TutorialUserRenewQualificationData{..}, selectedUsers)

src/Handler/Users.hs

@@ -101,7 +101,7 @@ postUsersR = do
           (AdminUserR <$> encrypt uid)
           (nameWidget userDisplayName userSurname)
       , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinked entUsr
-      , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
+      , sortable (Just "user-company") (i18nCell MsgTableCompanies)   $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
             companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
               E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
               E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
@@ -265,15 +265,9 @@ postUsersR = do
               Just needle -> (E.castString (user E.^. UserEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
                       E.||. (E.castString (user E.^. UserDisplayEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
             )
-         , ( "matriculation", FilterColumn $ \user (criteria :: Set.Set Text) -> if
+          , ( "personal-number"   , FilterColumn . E.mkContainsFilterWithComma Just $ (E.^. UserCompanyPersonalNumber))
-                | Set.null criteria -> E.true
+          , ( "matriculation"     , FilterColumn . E.mkContainsFilterWithComma Just $ (E.^. UserMatrikelnummer)) -- allows partial matches
-                | otherwise         -> E.any (\c -> user E.^. UserMatrikelnummer `E.hasInfix` E.val c) criteria
+          , ( "company-department", FilterColumn $ \user (criteria :: Set.Set Text) -> if                        -- exact filter on table UserAvs
-           )
-          , ( "personal-number", FilterColumn $ \user (criteria :: Set.Set Text) -> if
-                 | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still?
-                 | otherwise         -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria
-            )
-          , ( "company-department", FilterColumn $ \user (criteria :: Set.Set Text) -> if
                  | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still?
                  | otherwise         -> E.any (\c -> user E.^. UserCompanyDepartment `E.hasInfix` E.val c) criteria
             )
@@ -312,26 +306,32 @@ postUsersR = do
                       E.where_ $ (spvr E.^. UserSupervisorUser E.==. user E.^.UserId)
                         E.&&.  E.any (E.hasInfix (usrSpvr E.^. UserDisplayName)) (E.val <$> Set.toList criteria)
             )
-          , ( "avs-number", FilterColumn $ E.mkExistsFilter $ \user criterion ->
+          -- , ( "avs-number", FilterColumn $ E.mkExistsFilterWithComma CI.mk $ \user criterion -> -- note that this is an exact filter
-              E.from $ \usrAvs -> -- do 
+          --     E.from $ \usrAvs -> -- do 
-                E.where_ $ usrAvs E.^. UserAvsUser      E.==. user E.^.UserId
+          --       E.where_ $ user E.^. UserId E.==. usrAvs E.^. UserAvsUser
-                    E.&&.  ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
+          --           E.&&.  ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
-                          (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )
+          --                 (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )
+          --   )
+          , ( "is-supervisor", FilterColumn $ \user criterion -> case criterion of                
+                Last (Just True)   -> E.exists    . E.from $ \usrSpr -> E.where_ $ user E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor
+                Last (Just False)  -> E.notExists . E.from $ \usrSpr -> E.where_ $ user E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor
+                _                  -> E.val True :: E.SqlExpr (E.Value Bool)
             )
           ]
       , dbtFilterUI  = \mPrev -> mconcat
-          [ prismAForm (singletonFilter "user-search") mPrev $ aopt textField  (fslI MsgName)
+          [ prismAForm (singletonFilter "user-search")        mPrev $ aopt textField (fslI MsgName)
-          , prismAForm (singletonFilter "user-ident") mPrev $ aopt textField  (fslI MsgAdminUserIdent)
+          , prismAForm (singletonFilter "user-ident")         mPrev $ aopt textField (fslI MsgAdminUserIdent)
-          , prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgAdminUserEmail)
+          , prismAForm (singletonFilter "user-email")         mPrev $ aopt textField (fslI MsgAdminUserEmail)
-          -- , prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField  (fslI MsgTableMatrikelNr)          
+          , prismAForm (singletonFilter "personal-number" )   mPrev $ aopt textField (fslI MsgCompanyPersonalNumber     & setTooltip MsgTableFilterCommaPlus)
-          , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
+          , prismAForm (singletonFilter "matriculation")      mPrev $ aopt matriculationField  (fslI MsgTableMatrikelNr & setTooltip MsgTableFilterCommaPlus)    -- contains filter on UserMatrikelnummer
-          , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
+          -- , prismAForm (singletonFilter "avs-number" )        mPrev $ aopt textField (fslI MsgAvsPersonNo               & setTooltip MsgTableFilterCommaPlus) -- exact filter on table UserAvs
-          , prismAForm (singletonFilter "company-department" ) mPrev $ aopt textField (fslI MsgCompanyDepartment)
+          , prismAForm (singletonFilter "company-department") mPrev $ aopt textField (fslI MsgCompanyDepartment)
-          , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
+          , prismAForm (singletonFilter "user-company")       mPrev $ aopt textField (fslI MsgTableCompany)
-          , prismAForm (singletonFilter "user-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)
+          , prismAForm (singletonFilter "user-supervisor")    mPrev $ aopt textField (fslI MsgTableSupervisor)
-          , prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode)
+          , prismAForm (singletonFilter "school")             mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool)
-          , prismAForm (singletonFilter "school") mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool)
+          , prismAForm (singletonFilter "is-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgUserIsSupervisor)
-          , prismAForm (singletonFilter "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore)
+          , prismAForm (singletonFilter "auth-ldap"     . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode)          
+          , prismAForm (singletonFilter "ldap-sync"     . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore)
           ]
       , dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
       , dbtParams    = DBParamsForm

src/Handler/Utils.hs

@@ -38,6 +38,10 @@ import Handler.Utils.Term as Handler.Utils
 import Control.Monad.Logger
 
 
+-- | default check if the user an active admin
+checkAdmin :: (MonadHandler m, MonadAP (HandlerFor (HandlerSite m) )) => m Bool
+checkAdmin = liftHandler $ hasReadAccessTo AdminR
+
 
 -- | Prefix a message with a short course id,
 --   eg. for window title bars, etc.

src/Handler/Utils/Qualification.hs

@@ -133,8 +133,9 @@ selectRelevantBlock cutoff quid =
 ------------------------
 
 
-upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB () -- ignores blocking
+upsertQualificationUser :: QualificationId -> UTCTime -> Day -> Maybe Bool -> Text -> UserId -> DB () -- ignores blocking
-upsertQualificationUser  qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do
+upsertQualificationUser  qualificationUserQualification startTime qualificationUserValidUntil mbScheduleRenewal reason qualificationUserUser = do
+  let qualificationUserLastRefresh = utctDay startTime
   Entity quid _ <- upsert
     QualificationUser
       { qualificationUserFirstHeld        = qualificationUserLastRefresh      
@@ -149,7 +150,8 @@ upsertQualificationUser  qualificationUserQualification qualificationUserLastRef
       , QualificationUserLastRefresh        =. qualificationUserLastRefresh      
       ]
     )
-  
+  authUsr <- liftHandler maybeAuthId
+  insert_ $ QualificationUserBlock quid True startTime reason authUsr
   audit TransactionQualificationUserEdit
     { transactionQualificationUser            = quid
     , transactionQualification                = qualificationUserQualification

src/Utils.hs

@@ -312,6 +312,9 @@ citext2lower = Text.toLower . CI.original
 citext2string :: CI Text -> String 
 citext2string = Text.unpack . CI.original
 
+string2citext :: String -> CI Text
+string2citext = CI.mk . Text.pack
+
 -- | Convert or remove all non-ascii  characters, e.g. for filenames 
 text2asciiAlphaNum :: Text -> Text
 text2asciiAlphaNum = Text.filter (\c -> Char.isAlphaNum c && Char.isAscii c)
@@ -665,6 +668,11 @@ lastMaybe' l = fmap snd $ l ^? _Snoc
 minimumMaybe :: (MonoFoldable mono, Ord (Element mono)) => mono -> Maybe (Element mono)
 minimumMaybe = fmap minimum . fromNullable
 
+zipMaybes :: [Maybe a] -> [Maybe b] -> [(a,b)]
+zipMaybes (Just x:xs) (Just y:ys) = (x,y) : zipMaybes xs ys
+zipMaybes      (_:xs)      (_:ys) =         zipMaybes xs ys
+zipMaybes        _              _ = []
+
 -- | Merge/Add any attribute-value pair to an existing list of such pairs.
 --   If the attribute exists, the new valu will be prepended, separated by a single empty space
 insertAttr :: Text -> Text -> [(Text,Text)] -> [(Text,Text)]

test/Handler/SAPSpec.hs

@@ -0,0 +1,127 @@
+-- SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@faport.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+module Handler.SAPSpec where
+
+import TestImport
+-- import ModelSpec ()
+-- import CryptoID
+
+import Handler.SAP
+
+{-
+data BlockIntervalTest = BlockIntervalTest Day Day [(Day,Bool)]
+  deriving (Show, Eq, Ord)
+
+instance Arbitrary BlockIntervalTest where
+  arbitrary = do
+    blocks <- arbitrary
+    case blocks of 
+      [] -> do 
+        dFrom  <- arbitrary
+        dUntil <- arbitrary `suchThat` (dFrom <)
+        return $ BlockIntervalTest dFrom dUntil []
+      ((h,_):t') -> do
+        let ds = ncons h (fst <$> t')
+            dmin = minimum ds
+            dmax = maximum ds
+        dFrom  <- arbitrary `suchThat` (<= dmin)
+        dUntil <- arbitrary `suchThat` (>= dmax)
+        return $ BlockIntervalTest dFrom dUntil $ sort blocks  
+
+  shrink (BlockIntervalTest dFrom dUntil []) 
+    = [BlockIntervalTest dF dU [] | dF <- shrink dFrom, dU <- shrink dUntil, dF < dU]
+  shrink (BlockIntervalTest dFrom dUntil blocks) 
+    = [BlockIntervalTest dFrom dUntil b | b <- shrink blocks, all ((dFrom <=) . fst) b]
+-}
+
+{- These alternative implementations do NOT meet the specifications and thus cannot be used for testing 
+compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)]
+compileBlocks dfrom duntil []             = [(dfrom, duntil)]
+compileBlocks dfrom duntil [(d,False)]                              
+  | dend <- min duntil d, dfrom < dend    = [(dfrom, dend)] -- redundant, but common case
+  | otherwise                             = []
+compileBlocks dfrom duntil (p1@(d1,u1):p2@(d2,u2):bs)
+  | u1 == u2                              =               compileBlocks dfrom      duntil (p1:bs)   -- superfluous block/unblock
+  | d1 == d2                              =               compileBlocks dfrom      duntil (p2:bs)   -- eliminate same day changes
+  | u2, dfrom < d1, d1 < d2, d2 < duntil  = (dfrom, d1) : compileBlocks d2         duntil     bs    -- block and reinstated later
+compileBlocks dfrom duntil ((_,True ):bs) =               compileBlocks dfrom      duntil     bs    -- superfluous unblock
+compileBlocks dfrom duntil ((d,False):bs) 
+  | dfrom >= d =               compileBlocks dfrom      duntil     bs    -- should only occur if blocks/unblock happened on same day 
+                                                                                                 
+
+cmpBlocks :: BlockIntervalTest -> [(Day,Day)]
+cmpBlocks (BlockIntervalTest dFrom dUntil blocks) = makePeriods dFrom dUntil $ cleanBlocks $ sort blocks
+  where 
+    cleanBlocks ((_,True):r) = cleanBlocks r
+    cleanBlocks (b1@(d1,False):b2@(d2,True):r)
+      | d1 < d1   = b1:b2:cleanBlocks r
+      | otherwise =       cleanBlocks r
+    cleanBlocks (b1@(_,False):  (_,False):r) = cleanBlocks (b1:r)
+    cleanBlocks r@[(_,False)] = r
+    cleanBlocks [] = []
+
+    makePeriods a b ((d1,False):(d2,True):r) 
+      | b > d2 = (a,d1):makePeriods d2 b r
+      | otherwise = [(a,d1)]
+    makePeriods a b [(d,False)] = [(a,min b d)]
+    makePeriods a b _ = [(a,b)]
+-}
+
+
+spec :: Spec
+spec = do 
+  describe "SAP.compileBlocks" $ do
+    it "works on examples" . example $ do
+      let wA = fromGregorian 2002  1 11
+          wE = fromGregorian 2025  4 30
+          w0 = fromGregorian 2001  9 22
+          w1 = fromGregorian 2023  9 22
+          w2 = fromGregorian 2023 10 16
+          wF = fromGregorian 2023 10 17
+          w3 = fromGregorian 2023 11 17
+          w4 = fromGregorian 2024 01 21
+      compileBlocks wA wE []           `shouldBe` [(wA,wE)]
+      compileBlocks wA wE [(w1,False)] `shouldBe` [(wA,w1)]
+      compileBlocks wA wE [(w1,True)]  `shouldBe` [(wA,wE)]
+      compileBlocks wA wE [(w1,False),(w2,True)] `shouldBe` [(wA,w1),(w2,wE)]
+      compileBlocks wA wE [(wA,False),(w1,True)] `shouldBe` [(w1,wE)]
+      compileBlocks wA wE [(wA,True),(wA,False),(w1,True)]  `shouldBe` [(w1,wE)]
+      compileBlocks wA wE [(wA,False),(wA,True),(w1,True)]  `shouldBe` [(wA,wE)]
+      compileBlocks wA wE [(wA,False),(w1,True),(w2,False)] `shouldBe` [(w1,w2)]
+      compileBlocks wA wE [(w1,False),(w2,True),(w3,True)]  `shouldBe` [(wA,w1),(w2,wE)]    
+      compileBlocks wA wE [(w1,False),(succ w1,True),(succ w1,False),(w2,True)] `shouldBe` [(wA,succ w1),(w2,wE)]
+      compileBlocks wA wE [(w1,False),(w1,True),(w1,False),(w1,True),(w1,False),(w2,True)] `shouldBe` [(wA,w1),(w2,wE)]
+      compileBlocks wA wE [(w0,True),(w1,True),(w1,False),(w1,True),(w1,False),(w2,True),(w3,True)] `shouldBe` [(wA,w1),(w2,wE)]
+      compileBlocks wA wE [(w0,False),(w1,False),(w2,True),(w3,False),(w4,True)] `shouldBe` [(wA,w1),(w2,w3),(w4,wE)]
+      compileBlocks wA wE [(w1,False),(w2,True),(wF,True ),(w3,False)] `shouldBe` [(wA,w1),(w2,w3)]
+      compileBlocks wA wE [(w1,True),(w2,False),(wF,False),(w3,True)]  `shouldBe` [(wA,w2),(w3,wE)]
+      compileBlocks wA wE [(w2,False),(wF,False),(w3,True)] `shouldBe` [(wA,w2),(w3,wE)]
+      compileBlocks wA wE [(w2,False),(wF,False)] `shouldBe` [(wA,w2) ]
+
+    it "handles basic intervals" $ do
+      (d1,d2,d3) <- generate $ do
+        d1 <- arbitrary 
+        d2 <- arbitrary `suchThat` (d1 <)
+        d3 <- arbitrary `suchThat` (d1 <)
+        return (d1,d2,d3)
+      b <- generate arbitrary     
+      let test = compileBlocks d1 d2 [(d3,b)]
+      test `shouldBe` bool [(d1,min d2 d3)] [(d1,d2)] b
+
+    it "identifies two correct intervals" $ do
+      (d1,d2,d3,d4) <- generate $ do
+        d1 <- arbitrary 
+        d2 <- arbitrary `suchThat` (d1 <)
+        d3 <- arbitrary `suchThat` (d1 <)
+        d4 <- arbitrary `suchThat` (d3 <)
+        return (d1,d2,d3,d4)
+      b3 <- generate arbitrary
+      b4 <- generate arbitrary
+      let test   = compileBlocks d1 d2 [(d3,b3),(d4,b4)]
+          result | b3, b4       = [(d1, d2)]
+                 | b3           = [(d1, min d2 d4)]                 
+                 | b4, d2 > d4  = [(d1,d3),(d4,d2)]
+                 | otherwise    = [(d1, min d2 d3)]
+      test `shouldBe` result