From a7dcb30c7a465d9fce72b7fc3e605470b2b59814 Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Tue, 16 Dec 2025 08:06:09 -0500 Subject: feat(deploy): Complete mini-PaaS deployment system (t-266) - Add Omni/Deploy/ with Manifest, Deployer, Systemd, Caddy modules - Manifest CLI: show, update, add-service, list, rollback commands - Deployer: polls S3 manifest, pulls closures, manages systemd units - Caddy integration for dynamic reverse proxy routes - bild: auto-cache to S3, outputs STORE_PATH for push.sh - push.sh: supports both NixOS and service deploys - Biz.nix: simplified to base OS + deployer only - Services (podcastitlater-web/worker) now deployer-managed - Documentation: README.md with operations guide --- Omni/Deploy/Deployer.hs | 313 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 313 insertions(+) create mode 100644 Omni/Deploy/Deployer.hs (limited to 'Omni/Deploy/Deployer.hs') diff --git a/Omni/Deploy/Deployer.hs b/Omni/Deploy/Deployer.hs new file mode 100644 index 0000000..fe03f74 --- /dev/null +++ b/Omni/Deploy/Deployer.hs @@ -0,0 +1,313 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Mini-PaaS deployer service. +-- +-- Polls manifest from S3, compares to local state, pulls changed closures, +-- generates systemd units, updates Caddy routes, and manages GC roots. +-- +-- : out biz-deployer +-- : dep aeson +-- : dep amazonka +-- : dep amazonka-core +-- : dep amazonka-s3 +-- : dep directory +-- : dep http-conduit +-- : dep http-types +-- : dep time +module Omni.Deploy.Deployer + ( DeployerState (..), + loadState, + saveState, + pullClosure, + createGcRoot, + removeGcRoot, + deployService, + removeService, + reconcile, + runOnce, + runDaemon, + stateDir, + stateFile, + gcrootsDir, + main, + test, + ) +where + +import Alpha +import qualified Control.Concurrent as Concurrent +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as BL +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Network.HostName as HostName +import qualified Omni.Cli as Cli +import qualified Omni.Deploy.Caddy as Caddy +import qualified Omni.Deploy.Manifest as Manifest +import qualified Omni.Deploy.Systemd as Systemd +import qualified Omni.Log as Log +import qualified Omni.Test as Test +import qualified System.Directory as Dir +import qualified System.Exit as Exit +import System.FilePath (()) +import qualified System.Process as Process + +stateDir :: FilePath +stateDir = "/var/lib/biz-deployer" + +stateFile :: FilePath +stateFile = stateDir "state.json" + +gcrootsDir :: FilePath +gcrootsDir = "/nix/var/nix/gcroots/biz" + +s3Url :: String +s3Url = "s3://omni-nix-cache?profile=digitalocean&scheme=https&endpoint=nyc3.digitaloceanspaces.com" + +data DeployerState = DeployerState + { stateServices :: Map Text Text + } + deriving (Show, Eq, Generic, Aeson.FromJSON, Aeson.ToJSON) + +emptyState :: DeployerState +emptyState = DeployerState mempty + +loadState :: IO DeployerState +loadState = do + exists <- Dir.doesFileExist stateFile + if exists + then do + contents <- BL.readFile stateFile + case Aeson.eitherDecode contents of + Left _ -> pure emptyState + Right s -> pure s + else pure emptyState + +saveState :: DeployerState -> IO () +saveState st = do + Dir.createDirectoryIfMissing True stateDir + BL.writeFile stateFile (Aeson.encode st) + +getHostname :: IO Text +getHostname = HostName.getHostName /> Text.pack + +pullClosure :: Text -> IO Bool +pullClosure storePath = do + -- First check if the path already exists locally + exists <- Dir.doesDirectoryExist (Text.unpack storePath) + if exists + then do + Log.info ["deployer", "path already exists locally", storePath] + pure True + else do + (exitCode, _, stderr') <- + Process.readProcessWithExitCode + "nix" + [ "copy", + "--extra-experimental-features", + "nix-command", + "--from", + s3Url, + Text.unpack storePath + ] + "" + case exitCode of + Exit.ExitSuccess -> pure True + Exit.ExitFailure _ -> do + Log.fail ["deployer", "pull failed", storePath, Text.pack stderr'] + pure False + +createGcRoot :: Text -> Text -> IO FilePath +createGcRoot serviceName storePath = do + Dir.createDirectoryIfMissing True gcrootsDir + let rootPath = gcrootsDir Text.unpack serviceName + exists <- Dir.doesPathExist rootPath + when exists <| Dir.removeFile rootPath + Dir.createFileLink (Text.unpack storePath) rootPath + pure rootPath + +removeGcRoot :: Text -> IO () +removeGcRoot serviceName = do + let rootPath = gcrootsDir Text.unpack serviceName + exists <- Dir.doesPathExist rootPath + when exists <| Dir.removeFile rootPath + +deployService :: Manifest.Service -> DeployerState -> IO (Bool, DeployerState) +deployService svc st = do + let name = Manifest.serviceName svc + path = Manifest.storePath (Manifest.serviceArtifact svc) + currentPath = Map.lookup name (stateServices st) + + if currentPath == Just path + then do + Log.info ["deployer", name, "already at", path] + pure (True, st) + else do + Log.info ["deployer", "deploying", name, fromMaybe "new" currentPath, "->", path] + + pulled <- pullClosure path + if don't pulled + then do + Log.fail ["deployer", "failed to pull", name] + pure (False, st) + else do + _ <- createGcRoot name path + + _ <- Systemd.writeUnit Systemd.servicesDir svc + _ <- Systemd.createSymlink Systemd.servicesDir "/run/systemd/system" svc + Systemd.reloadAndRestart name + + case Manifest.serviceHttp svc of + Just _ -> void <| Caddy.upsertRoute Caddy.caddyAdmin svc + Nothing -> pure () + + let newSt = st {stateServices = Map.insert name path (stateServices st)} + Log.good ["deployer", "deployed", name] + pure (True, newSt) + +removeService :: Text -> DeployerState -> IO DeployerState +removeService svcName st = do + Log.info ["deployer", "removing", svcName] + + Systemd.stopAndDisable svcName + Systemd.removeUnit Systemd.servicesDir "/run/systemd/system" svcName + _ <- Caddy.deleteRoute Caddy.caddyAdmin svcName + removeGcRoot svcName + + pure <| st {stateServices = Map.delete svcName (stateServices st)} + +reconcile :: Manifest.Manifest -> DeployerState -> IO DeployerState +reconcile manifest st = do + hostname <- getHostname + + let mfstServices = + Set.fromList + [ Manifest.serviceName svc + | svc <- Manifest.manifestServices manifest, + hostname `elem` Manifest.serviceHosts svc + ] + localServices = Set.fromList <| Map.keys (stateServices st) + toRemove = localServices Set.\\ mfstServices + + st' <- foldM (\s name -> removeService name s) st (Set.toList toRemove) + + foldM + ( \s svc -> + if hostname `elem` Manifest.serviceHosts svc + then do + (_, newSt) <- deployService svc s + pure newSt + else pure s + ) + st' + (Manifest.manifestServices manifest) + +runOnce :: IO Bool +runOnce = do + Log.info ["deployer", "starting reconciliation"] + + manifest <- Manifest.loadManifestFromS3 + case manifest of + Nothing -> do + Log.warn ["deployer", "no manifest found in S3"] + pure False + Just m -> do + st <- loadState + st' <- reconcile m st + saveState st' + Log.good ["deployer", "reconciliation complete"] + pure True + +runDaemon :: Int -> IO () +runDaemon intervalSeconds = do + Log.info ["deployer", "starting daemon", "interval=" <> tshow intervalSeconds <> "s"] + forever <| do + result <- try runOnce + case result of + Left (e :: SomeException) -> + Log.fail ["deployer", "error in reconciliation", tshow e] + Right _ -> pure () + Concurrent.threadDelay (intervalSeconds * 1_000_000) + +help :: Cli.Docopt +help = + [Cli.docopt| +biz-deployer - Mini-PaaS deployment agent + +Usage: + biz-deployer test + biz-deployer once + biz-deployer daemon [] + biz-deployer status + biz-deployer (-h | --help) + +Commands: + test Run tests + once Run a single reconciliation cycle + daemon Run as daemon with interval in seconds (default: 300) + status Show current deployer state + +Options: + -h --help Show this help +|] + +move :: Cli.Arguments -> IO () +move args + | args `Cli.has` Cli.command "once" = do + success <- runOnce + if success + then Exit.exitSuccess + else Exit.exitWith (Exit.ExitFailure 1) + | args `Cli.has` Cli.command "daemon" = do + let interval = + Cli.getArg args (Cli.argument "interval") + +> readMaybe + |> fromMaybe 300 + runDaemon interval + | args `Cli.has` Cli.command "status" = do + st <- loadState + BL.putStr <| Aeson.encode st + putStrLn ("" :: String) + | otherwise = do + Log.fail ["deployer", "unknown command"] + Exit.exitWith (Exit.ExitFailure 1) + +test :: Test.Tree +test = + Test.group + "Omni.Deploy.Deployer" + [ test_emptyState, + test_stateJsonRoundtrip + ] + +test_emptyState :: Test.Tree +test_emptyState = + Test.unit "empty state has no services" <| do + let st = emptyState + Map.null (stateServices st) Test.@=? True + +test_stateJsonRoundtrip :: Test.Tree +test_stateJsonRoundtrip = + Test.unit "state JSON roundtrip" <| do + let testState = + DeployerState + { stateServices = + Map.fromList + [ ("svc-a", "/nix/store/abc"), + ("svc-b", "/nix/store/xyz") + ] + } + let encoded = Aeson.encode testState + case Aeson.eitherDecode encoded of + Left err -> Test.assertFailure err + Right decoded -> stateServices decoded Test.@=? stateServices testState + +main :: IO () +main = Cli.main <| Cli.Plan help move test pure -- cgit v1.2.3 From 260b7b83b0ec396bb880038f4c93f977af0056c5 Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Tue, 16 Dec 2025 14:14:41 -0500 Subject: Fix hlint errors in Deploy modules - Systemd: use list comprehension instead of if-then-else - Manifest: use operator, replace case with maybe - Deployer: use newtype, use flip removeService - Caddy: use newtype for single-field types --- Omni/Deploy/Deployer.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'Omni/Deploy/Deployer.hs') diff --git a/Omni/Deploy/Deployer.hs b/Omni/Deploy/Deployer.hs index fe03f74..ee06907 100644 --- a/Omni/Deploy/Deployer.hs +++ b/Omni/Deploy/Deployer.hs @@ -71,7 +71,7 @@ gcrootsDir = "/nix/var/nix/gcroots/biz" s3Url :: String s3Url = "s3://omni-nix-cache?profile=digitalocean&scheme=https&endpoint=nyc3.digitaloceanspaces.com" -data DeployerState = DeployerState +newtype DeployerState = DeployerState { stateServices :: Map Text Text } deriving (Show, Eq, Generic, Aeson.FromJSON, Aeson.ToJSON) @@ -196,7 +196,7 @@ reconcile manifest st = do localServices = Set.fromList <| Map.keys (stateServices st) toRemove = localServices Set.\\ mfstServices - st' <- foldM (\s name -> removeService name s) st (Set.toList toRemove) + st' <- foldM (flip removeService) st (Set.toList toRemove) foldM ( \s svc -> -- cgit v1.2.3 From 06f1e86433f3a4a15bccd51fd2aba0960410c0c1 Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Wed, 17 Dec 2025 09:21:06 -0500 Subject: Fix deployer checking stale state instead of actual running services The deployer compared its in-memory stateServices map to decide if a service needed restarting. When the deployer restarted, this state was lost, causing it to think services were 'already at' the desired path when they were actually running old code. Changes: - Add getRunningStorePath to Systemd module to read actual store path - Update deployService to query systemd instead of stale in-memory state - Add DerivingStrategies extension to Deployer.hs --- Omni/Deploy/Deployer.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) (limited to 'Omni/Deploy/Deployer.hs') diff --git a/Omni/Deploy/Deployer.hs b/Omni/Deploy/Deployer.hs index ee06907..7e57b34 100644 --- a/Omni/Deploy/Deployer.hs +++ b/Omni/Deploy/Deployer.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} @@ -74,7 +75,8 @@ s3Url = "s3://omni-nix-cache?profile=digitalocean&scheme=https&endpoint=nyc3.dig newtype DeployerState = DeployerState { stateServices :: Map Text Text } - deriving (Show, Eq, Generic, Aeson.FromJSON, Aeson.ToJSON) + deriving (Show, Eq, Generic) + deriving anyclass (Aeson.FromJSON, Aeson.ToJSON) emptyState :: DeployerState emptyState = DeployerState mempty @@ -143,14 +145,16 @@ deployService :: Manifest.Service -> DeployerState -> IO (Bool, DeployerState) deployService svc st = do let name = Manifest.serviceName svc path = Manifest.storePath (Manifest.serviceArtifact svc) - currentPath = Map.lookup name (stateServices st) - if currentPath == Just path + -- Check what's actually running in systemd instead of in-memory state + runningPath <- Systemd.getRunningStorePath name + + if runningPath == Just path then do Log.info ["deployer", name, "already at", path] pure (True, st) else do - Log.info ["deployer", "deploying", name, fromMaybe "new" currentPath, "->", path] + Log.info ["deployer", "deploying", name, fromMaybe "new" runningPath, "->", path] pulled <- pullClosure path if don't pulled -- cgit v1.2.3