1 files changed, 313 insertions, 0 deletions
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 [<interval>]
+  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