fix: migrate so as not to resend allocation notifications

shell.nix

@@ -20,7 +20,7 @@ let
   '';
 
   override = oldAttrs: {
-    nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ nodejs-14_x postgresql openldap google-chrome exiftool memcached minio minio-client ]) ++ (with pkgs.haskellPackages; [ stack yesod-bin hlint cabal-install weeder profiteur ]);
+    nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ nodejs-14_x postgresql_12 openldap google-chrome exiftool memcached minio minio-client ]) ++ (with pkgs.haskellPackages; [ stack yesod-bin hlint cabal-install weeder profiteur ]);
     shellHook = ''
       export PROMPT_INFO="${oldAttrs.name}"
 

src/Jobs/Types.hs

@@ -21,7 +21,10 @@ module Jobs.Types
   , module Cron
   ) where
 
-import Import.NoFoundation hiding (Unique, state)
+import Import.NoModel hiding (Unique, state)
+import Settings.Log
+import Utils.Lens.TH
+import Model
 
 import qualified Data.Aeson as Aeson
 

src/Model/Migration.hs

@@ -5,19 +5,24 @@ module Model.Migration
   , requiresMigration
   ) where
 
-import Import.NoModel
+import Import.NoModel hiding (Max(..), Last(..))
 import Model
+import Jobs.Types
 import Audit.Types
 import Model.Migration.Version
 import qualified Model.Migration.Types as Legacy
 import qualified Data.Map as Map
 
 import qualified Data.Set as Set
+import qualified Data.HashMap.Strict as HashMap
 
 import qualified Data.Text as Text
 
 import qualified Data.Conduit.List as C
 
+import Data.Semigroup (Max(..), Last(..))
+
+
 import Database.Persist.Sql
 import Database.Persist.Sql.Raw.QQ
 import Database.Persist.Postgresql
@@ -881,6 +886,33 @@ customMigrations = Map.fromListWith (>>)
           ALTER TABLE "file_content" DROP COLUMN "id";
         |]
     )
+  , ( AppliedMigrationKey [migrationVersion|38.0.0|] [version|39.0.0|]
+    , whenM (and2M (tableExists "cron_last_exec") (tableExists "allocation")) $ do
+        let
+          allocationTimes :: EntityField Allocation (Maybe UTCTime)
+                          -> ReaderT SqlBackend m (MergeHashMap UTCTime (Set AllocationId, Max UTCTime, Last InstanceId))
+          allocationTimes aField = do
+            ress <- [sqlQQ|SELECT ^{Allocation}.@{AllocationId},^{Allocation}.@{aField},^{CronLastExec}.@{CronLastExecTime},^{CronLastExec}.@{CronLastExecInstance} FROM ^{Allocation} INNER JOIN ^{CronLastExec} ON ^{CronLastExec}.@{CronLastExecJob}->'job' = '"queue-notification"' AND ^{CronLastExec}.@{CronLastExecJob}->'notification'->'notification' = '"allocation-staff-register"' AND ^{CronLastExec}.@{CronLastExecJob}->'notification'->'allocation' = (^{Allocation}.@{AllocationId} :: text) :: jsonb ORDER BY ^{Allocation}.@{aField} ASC;|]
+            return . flip foldMap ress $ \(Single allocId, Single allocTime, Single execTime, Single execInstance)
+              -> _MergeHashMap # HashMap.singleton allocTime (Set.singleton allocId, Max execTime, Last execInstance)
+
+        staffRegisterFroms <- allocationTimes AllocationStaffRegisterFrom
+        forM_ staffRegisterFroms $ \(nAllocations, Max cronLastExecTime, Last cronLastExecInstance) ->
+          insert_ CronLastExec{ cronLastExecJob = toJSON $ JobQueueNotification NotificationAllocationStaffRegister{..}, .. }
+
+        registerFroms <- allocationTimes AllocationRegisterFrom
+        forM_ registerFroms $ \(nAllocations, Max cronLastExecTime, Last cronLastExecInstance) ->
+          insert_ CronLastExec{ cronLastExecJob = toJSON $ JobQueueNotification NotificationAllocationRegister{..}, .. }
+
+        staffAllocationFroms <- allocationTimes AllocationStaffAllocationFrom
+        forM_ staffAllocationFroms $ \(nAllocations, Max cronLastExecTime, Last cronLastExecInstance) ->
+          insert_ CronLastExec{ cronLastExecJob = toJSON $ JobQueueNotification NotificationAllocationAllocation{..}, .. }
+
+        registerTos <- allocationTimes AllocationRegisterTo
+        forM_ registerTos $ \(nAllocations, Max cronLastExecTime, Last cronLastExecInstance) ->
+          insert_ CronLastExec{ cronLastExecJob = toJSON $ JobQueueNotification NotificationAllocationUnratedApplications{..}, .. }
+
+    )
   ]
 
 

src/Utils.hs

@@ -1172,6 +1172,12 @@ newtype MergeHashMap k v = MergeHashMap { unMergeHashMap :: HashMap k v }
 makePrisms ''MergeHashMap
 makeWrapped ''MergeHashMap
 
+type instance Element (MergeHashMap k v) = v
+  
+instance MonoFoldable (MergeHashMap k v)
+instance MonoFunctor (MergeHashMap k v)
+instance MonoTraversable (MergeHashMap k v)
+
 instance Traversable (MergeHashMap k) where
   traverse = _MergeHashMap . traverse
 

src/Utils/Metrics.hs

@@ -9,7 +9,8 @@ module Utils.Metrics
   , LoginOutcome(..), observeLoginOutcome
   ) where
 
-import Import.NoFoundation hiding (Vector, Info)
+import Import.NoModel hiding (Vector, Info)
+import Model
 import Prometheus
 import Prometheus.Metric.GHC