path: root/Omni/Deploy/Deployer.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# 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"

newtype DeployerState = DeployerState
  { stateServices :: Map Text Text
  }
  deriving (Show, Eq, Generic)
  deriving anyclass (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)

  -- 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" runningPath, "->", 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 (flip removeService) 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