diff --git a/shell.nix b/shell.nix index 90eb4f2a4..33411fdad 100644 --- a/shell.nix +++ b/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}" diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 3a3f96ce9..729cd356b 100644 --- a/src/Jobs/Types.hs +++ b/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 diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 6726fda53..5ebd46b6f 100644 --- a/src/Model/Migration.hs +++ b/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{..}, .. } + + ) ] diff --git a/src/Utils.hs b/src/Utils.hs index 4d0f216fc..6a5bd9105 100644 --- a/src/Utils.hs +++ b/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 diff --git a/src/Utils/Metrics.hs b/src/Utils/Metrics.hs index 514b6d1ca..34265c36a 100644 --- a/src/Utils/Metrics.hs +++ b/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