1 files changed, 673 insertions, 0 deletions
diff --git a/Omni/Deploy/Manifest.hs b/Omni/Deploy/Manifest.hs
new file mode 100644
index 0000000..e0d0b78
--- /dev/null
+++ b/Omni/Deploy/Manifest.hs
@@ -0,0 +1,673 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Manifest schema and S3 operations for the mini-PaaS deployment system.
+--
+-- Uses aws CLI for S3 operations (simpler than amazonka, already available).
+--
+-- : out deploy-manifest
+-- : dep aeson
+-- : dep time
+-- : dep directory
+-- : dep temporary
+-- : run awscli2
+module Omni.Deploy.Manifest
+  ( Artifact (..),
+    Exec (..),
+    Http (..),
+    Systemd (..),
+    Hardening (..),
+    Service (..),
+    Manifest (..),
+    findService,
+    updateService,
+    createEmptyManifest,
+    loadManifestFromS3,
+    saveManifestToS3,
+    archiveManifest,
+    listArchivedManifests,
+    rollbackToManifest,
+    s3Bucket,
+    s3Endpoint,
+    main,
+    test,
+  )
+where
+
+import Alpha
+import Data.Aeson ((.!=), (.:), (.:?), (.=))
+import qualified Data.Aeson as Aeson
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as TE
+import Data.Time (UTCTime, getCurrentTime)
+import Data.Time.Format.ISO8601 (iso8601Show)
+import qualified Omni.Cli as Cli
+import qualified Omni.Log as Log
+import qualified Omni.Test as Test
+import qualified System.Exit as Exit
+import qualified System.IO as IO
+import qualified System.IO.Temp as Temp
+import qualified System.Process as Process
+
+s3Bucket :: Text
+s3Bucket = "omni-nix-cache"
+
+s3Endpoint :: Text
+s3Endpoint = "https://nyc3.digitaloceanspaces.com"
+
+data Artifact = Artifact
+  { artifactType :: Text,
+    storePath :: Text
+  }
+  deriving (Show, Eq, Generic)
+
+instance Aeson.FromJSON Artifact where
+  parseJSON =
+    Aeson.withObject "Artifact" <| \o ->
+      Artifact
+        </ (o .:? "type" .!= "nix-closure")
+        <*> o
+        .: "storePath"
+
+instance Aeson.ToJSON Artifact where
+  toJSON Artifact {..} =
+    Aeson.object
+      [ "type" .= artifactType,
+        "storePath" .= storePath
+      ]
+
+data Exec = Exec
+  { execCommand :: Maybe Text,
+    execUser :: Text,
+    execGroup :: Text
+  }
+  deriving (Show, Eq, Generic)
+
+instance Aeson.FromJSON Exec where
+  parseJSON =
+    Aeson.withObject "Exec" <| \o ->
+      Exec
+        </ (o .:? "command")
+        <*> o
+        .:? "user"
+        .!= "root"
+        <*> o
+        .:? "group"
+        .!= "root"
+
+instance Aeson.ToJSON Exec where
+  toJSON Exec {..} =
+    Aeson.object
+      [ "command" .= execCommand,
+        "user" .= execUser,
+        "group" .= execGroup
+      ]
+
+defaultExec :: Exec
+defaultExec = Exec Nothing "root" "root"
+
+data Http = Http
+  { httpDomain :: Text,
+    httpPath :: Text,
+    httpInternalPort :: Int
+  }
+  deriving (Show, Eq, Generic)
+
+instance Aeson.FromJSON Http where
+  parseJSON =
+    Aeson.withObject "Http" <| \o ->
+      Http
+        </ (o .: "domain")
+        <*> o
+        .:? "path"
+        .!= "/"
+        <*> o
+        .: "internalPort"
+
+instance Aeson.ToJSON Http where
+  toJSON Http {..} =
+    Aeson.object
+      [ "domain" .= httpDomain,
+        "path" .= httpPath,
+        "internalPort" .= httpInternalPort
+      ]
+
+data Systemd = Systemd
+  { systemdAfter :: [Text],
+    systemdRequires :: [Text],
+    systemdRestart :: Text,
+    systemdRestartSec :: Int
+  }
+  deriving (Show, Eq, Generic)
+
+instance Aeson.FromJSON Systemd where
+  parseJSON =
+    Aeson.withObject "Systemd" <| \o ->
+      Systemd
+        </ (o .:? "after" .!= ["network-online.target"])
+        <*> o
+        .:? "requires"
+        .!= []
+        <*> o
+        .:? "restart"
+        .!= "on-failure"
+        <*> o
+        .:? "restartSec"
+        .!= 5
+
+instance Aeson.ToJSON Systemd where
+  toJSON Systemd {..} =
+    Aeson.object
+      [ "after" .= systemdAfter,
+        "requires" .= systemdRequires,
+        "restart" .= systemdRestart,
+        "restartSec" .= systemdRestartSec
+      ]
+
+defaultSystemd :: Systemd
+defaultSystemd = Systemd ["network-online.target"] [] "on-failure" 5
+
+data Hardening = Hardening
+  { hardeningDynamicUser :: Bool,
+    hardeningPrivateTmp :: Bool,
+    hardeningProtectSystem :: Text,
+    hardeningProtectHome :: Bool
+  }
+  deriving (Show, Eq, Generic)
+
+instance Aeson.FromJSON Hardening where
+  parseJSON =
+    Aeson.withObject "Hardening" <| \o ->
+      Hardening
+        </ (o .:? "dynamicUser" .!= False)
+        <*> o
+        .:? "privateTmp"
+        .!= True
+        <*> o
+        .:? "protectSystem"
+        .!= "strict"
+        <*> o
+        .:? "protectHome"
+        .!= True
+
+instance Aeson.ToJSON Hardening where
+  toJSON Hardening {..} =
+    Aeson.object
+      [ "dynamicUser" .= hardeningDynamicUser,
+        "privateTmp" .= hardeningPrivateTmp,
+        "protectSystem" .= hardeningProtectSystem,
+        "protectHome" .= hardeningProtectHome
+      ]
+
+defaultHardening :: Hardening
+defaultHardening = Hardening False True "strict" True
+
+data Service = Service
+  { serviceName :: Text,
+    serviceArtifact :: Artifact,
+    serviceHosts :: [Text],
+    serviceExec :: Exec,
+    serviceEnv :: Map Text Text,
+    serviceEnvFile :: Maybe Text,
+    serviceHttp :: Maybe Http,
+    serviceSystemd :: Systemd,
+    serviceHardening :: Hardening,
+    serviceRevision :: Maybe Text
+  }
+  deriving (Show, Eq, Generic)
+
+instance Aeson.FromJSON Service where
+  parseJSON =
+    Aeson.withObject "Service" <| \o ->
+      Service
+        </ (o .: "name")
+        <*> o
+        .: "artifact"
+        <*> o
+        .:? "hosts"
+        .!= ["biz"]
+        <*> o
+        .:? "exec"
+        .!= defaultExec
+        <*> o
+        .:? "env"
+        .!= mempty
+        <*> o
+        .:? "envFile"
+        <*> o
+        .:? "http"
+        <*> o
+        .:? "systemd"
+        .!= defaultSystemd
+        <*> o
+        .:? "hardening"
+        .!= defaultHardening
+        <*> o
+        .:? "revision"
+
+instance Aeson.ToJSON Service where
+  toJSON Service {..} =
+    Aeson.object
+      [ "name" .= serviceName,
+        "artifact" .= serviceArtifact,
+        "hosts" .= serviceHosts,
+        "exec" .= serviceExec,
+        "env" .= serviceEnv,
+        "envFile" .= serviceEnvFile,
+        "http" .= serviceHttp,
+        "systemd" .= serviceSystemd,
+        "hardening" .= serviceHardening,
+        "revision" .= serviceRevision
+      ]
+
+data Manifest = Manifest
+  { manifestVersion :: Int,
+    manifestGeneration :: UTCTime,
+    manifestServices :: [Service]
+  }
+  deriving (Show, Eq, Generic)
+
+instance Aeson.FromJSON Manifest where
+  parseJSON =
+    Aeson.withObject "Manifest" <| \o ->
+      Manifest
+        </ (o .:? "version" .!= 1)
+        <*> o
+        .: "generation"
+        <*> o
+        .:? "services"
+        .!= []
+
+instance Aeson.ToJSON Manifest where
+  toJSON Manifest {..} =
+    Aeson.object
+      [ "version" .= manifestVersion,
+        "generation" .= manifestGeneration,
+        "services" .= manifestServices
+      ]
+
+findService :: Text -> Manifest -> Maybe Service
+findService name manifest =
+  find (\s -> serviceName s == name) (manifestServices manifest)
+
+updateService :: Text -> Text -> Maybe Text -> Manifest -> Either Text Manifest
+updateService name newStorePath revision manifest =
+  case findService name manifest of
+    Nothing -> Left <| "Service '" <> name <> "' not found in manifest"
+    Just _ -> Right <| manifest {manifestServices = updatedServices}
+  where
+    updatedServices = map updateIfMatch (manifestServices manifest)
+    updateIfMatch svc
+      | serviceName svc == name =
+          svc
+            { serviceArtifact = (serviceArtifact svc) {storePath = newStorePath},
+              serviceRevision = revision
+            }
+      | otherwise = svc
+
+createEmptyManifest :: IO Manifest
+createEmptyManifest = do
+  now <- getCurrentTime
+  pure <| Manifest 1 now []
+
+awsS3Args :: [String]
+awsS3Args =
+  [ "--endpoint-url",
+    Text.unpack s3Endpoint,
+    "--profile",
+    "digitalocean"
+  ]
+
+s3Get :: Text -> FilePath -> IO Bool
+s3Get key destPath = do
+  let url = "s3://" <> Text.unpack s3Bucket <> "/" <> Text.unpack key
+      args = ["s3", "cp"] ++ awsS3Args ++ [url, destPath]
+  (exitCode, _, _) <- Process.readProcessWithExitCode "aws" args ""
+  pure <| exitCode == Exit.ExitSuccess
+
+s3Put :: FilePath -> Text -> IO Bool
+s3Put srcPath key = do
+  let url = "s3://" <> Text.unpack s3Bucket <> "/" <> Text.unpack key
+      args = ["s3", "cp"] ++ awsS3Args ++ [srcPath, url]
+  (exitCode, _, _) <- Process.readProcessWithExitCode "aws" args ""
+  pure <| exitCode == Exit.ExitSuccess
+
+s3List :: Text -> IO [Text]
+s3List prefix = do
+  let url = "s3://" <> Text.unpack s3Bucket <> "/" <> Text.unpack prefix
+      args = ["s3", "ls"] ++ awsS3Args ++ [url]
+  (exitCode, stdout', _) <- Process.readProcessWithExitCode "aws" args ""
+  case exitCode of
+    Exit.ExitSuccess ->
+      pure <| parseS3ListOutput (Text.pack stdout')
+    Exit.ExitFailure _ -> pure []
+
+parseS3ListOutput :: Text -> [Text]
+parseS3ListOutput output =
+  output
+    |> Text.lines
+    |> map extractFilename
+    |> filter (not <. Text.null)
+  where
+    extractFilename line =
+      case Text.words line of
+        [_, _, _, filename] -> filename
+        _ -> ""
+
+loadManifestFromS3 :: IO (Maybe Manifest)
+loadManifestFromS3 = loadManifestFromS3' "manifest.json"
+
+loadManifestFromS3' :: Text -> IO (Maybe Manifest)
+loadManifestFromS3' key = do
+  Temp.withSystemTempFile "manifest.json" <| \tmpPath tmpHandle -> do
+    IO.hClose tmpHandle
+    success <- s3Get key tmpPath
+    if success
+      then do
+        contents <- BL.readFile tmpPath
+        case Aeson.eitherDecode contents of
+          Left _ -> pure Nothing
+          Right manifest -> pure <| Just manifest
+      else pure Nothing
+
+archiveManifest :: Manifest -> IO Text
+archiveManifest manifest = do
+  let timestamp =
+        iso8601Show (manifestGeneration manifest)
+          |> filter (\c -> c /= ':' && c /= '-')
+          |> Text.pack
+      archiveKey = "manifests/manifest-" <> timestamp <> ".json"
+  Temp.withSystemTempFile "manifest.json" <| \tmpPath tmpHandle -> do
+    BL.hPut tmpHandle (Aeson.encode manifest)
+    IO.hClose tmpHandle
+    _ <- s3Put tmpPath archiveKey
+    pure archiveKey
+
+listArchivedManifests :: IO [Text]
+listArchivedManifests = do
+  files <- s3List "manifests/"
+  pure <| filter (Text.isSuffixOf ".json") files
+
+rollbackToManifest :: Text -> IO Bool
+rollbackToManifest archiveKey = do
+  let fullKey =
+        if "manifests/" `Text.isPrefixOf` archiveKey
+          then archiveKey
+          else "manifests/" <> archiveKey
+  archived <- loadManifestFromS3' fullKey
+  case archived of
+    Nothing -> pure False
+    Just manifest -> do
+      saveManifestToS3 manifest
+      pure True
+
+saveManifestToS3 :: Manifest -> IO ()
+saveManifestToS3 = saveManifestToS3' "manifest.json"
+
+saveManifestToS3' :: Text -> Manifest -> IO ()
+saveManifestToS3' key manifest = do
+  existing <- loadManifestFromS3' key
+  case existing of
+    Just old -> void <| archiveManifest old
+    Nothing -> pure ()
+
+  now <- getCurrentTime
+  let updatedManifest = manifest {manifestGeneration = now}
+  Temp.withSystemTempFile "manifest.json" <| \tmpPath tmpHandle -> do
+    BL.hPut tmpHandle (Aeson.encode updatedManifest)
+    IO.hClose tmpHandle
+    _ <- s3Put tmpPath key
+    pure ()
+
+help :: Cli.Docopt
+help =
+  [Cli.docopt|
+deploy-manifest - Manage deployment manifest in S3
+
+Usage:
+  deploy-manifest test
+  deploy-manifest init
+  deploy-manifest show
+  deploy-manifest update <name> <store-path> [<revision>]
+  deploy-manifest add-service <json>
+  deploy-manifest list
+  deploy-manifest rollback <archive>
+  deploy-manifest (-h | --help)
+
+Commands:
+  test         Run tests
+  init         Initialize empty manifest in S3
+  show         Show current manifest
+  update       Update service store path in manifest
+  add-service  Add a new service from JSON
+  list         List archived manifest generations
+  rollback     Restore a previous manifest version
+
+Options:
+  -h --help    Show this help
+|]
+
+move :: Cli.Arguments -> IO ()
+move args
+  | args `Cli.has` Cli.command "init" = do
+      existing <- loadManifestFromS3
+      case existing of
+        Just _ -> do
+          Log.fail ["manifest", "already exists"]
+          Exit.exitWith (Exit.ExitFailure 1)
+        Nothing -> do
+          manifest <- createEmptyManifest
+          saveManifestToS3 manifest
+          Log.good ["manifest", "initialized empty manifest"]
+  | args `Cli.has` Cli.command "show" = do
+      manifest <- loadManifestFromS3
+      case manifest of
+        Nothing -> putStrLn ("no manifest found" :: String)
+        Just m -> BL.putStr <| Aeson.encode m
+  | args `Cli.has` Cli.command "update" = do
+      let name =
+            Cli.getArg args (Cli.argument "name")
+              |> fromMaybe ""
+              |> Text.pack
+          storePath' =
+            Cli.getArg args (Cli.argument "store-path")
+              |> fromMaybe ""
+              |> Text.pack
+          revision =
+            Cli.getArg args (Cli.argument "revision")
+              /> Text.pack
+      manifest <- loadManifestFromS3
+      case manifest of
+        Nothing -> do
+          Log.fail ["manifest", "no manifest found in S3"]
+          Exit.exitWith (Exit.ExitFailure 1)
+        Just m -> case updateService name storePath' revision m of
+          Left err -> do
+            Log.fail ["manifest", err]
+            Exit.exitWith (Exit.ExitFailure 1)
+          Right updated -> do
+            saveManifestToS3 updated
+            Log.good ["manifest", "updated", name, "->", storePath']
+  | args `Cli.has` Cli.command "add-service" = do
+      let jsonStr =
+            Cli.getArg args (Cli.argument "json")
+              |> fromMaybe ""
+      case Aeson.eitherDecode (BL.fromStrict <| TE.encodeUtf8 <| Text.pack jsonStr) of
+        Left err -> do
+          Log.fail ["manifest", "invalid JSON:", Text.pack err]
+          Exit.exitWith (Exit.ExitFailure 1)
+        Right svc -> do
+          manifest <- loadManifestFromS3
+          m <- maybe createEmptyManifest pure manifest
+          case findService (serviceName svc) m of
+            Just _ -> do
+              Log.fail ["manifest", "service already exists:", serviceName svc]
+              Exit.exitWith (Exit.ExitFailure 1)
+            Nothing -> do
+              let newManifest = m {manifestServices = manifestServices m ++ [svc]}
+              saveManifestToS3 newManifest
+              Log.good ["manifest", "added service", serviceName svc]
+  | args `Cli.has` Cli.command "list" = do
+      archives <- listArchivedManifests
+      if null archives
+        then putStrLn ("no archived manifests found" :: String)
+        else
+          forM_ archives <| \archive -> do
+            putStrLn <| Text.unpack archive
+  | args `Cli.has` Cli.command "rollback" = do
+      let archive =
+            Cli.getArg args (Cli.argument "archive")
+              |> fromMaybe ""
+              |> Text.pack
+      success <- rollbackToManifest archive
+      if success
+        then Log.good ["manifest", "rolled back to", archive]
+        else do
+          Log.fail ["manifest", "failed to rollback to", archive]
+          Exit.exitWith (Exit.ExitFailure 1)
+  | otherwise = do
+      Log.fail ["manifest", "unknown command"]
+      Exit.exitWith (Exit.ExitFailure 1)
+
+test :: Test.Tree
+test =
+  Test.group
+    "Omni.Deploy.Manifest"
+    [ test_artifactDefaults,
+      test_serviceDefaults,
+      test_manifestJsonRoundtrip,
+      test_updateService,
+      test_findService
+    ]
+
+test_artifactDefaults :: Test.Tree
+test_artifactDefaults =
+  Test.unit "artifact defaults type to nix-closure" <| do
+    let json = "{\"storePath\": \"/nix/store/abc123\"}"
+    case Aeson.eitherDecode json of
+      Left err -> Test.assertFailure err
+      Right (artifact :: Artifact) ->
+        artifactType artifact Test.@=? "nix-closure"
+
+test_serviceDefaults :: Test.Tree
+test_serviceDefaults =
+  Test.unit "service has correct defaults" <| do
+    let json = "{\"name\": \"test-svc\", \"artifact\": {\"storePath\": \"/nix/store/xyz\"}}"
+    case Aeson.eitherDecode json of
+      Left err -> Test.assertFailure err
+      Right (svc :: Service) -> do
+        serviceHosts svc Test.@=? ["biz"]
+        execUser (serviceExec svc) Test.@=? "root"
+        systemdRestart (serviceSystemd svc) Test.@=? "on-failure"
+        hardeningPrivateTmp (serviceHardening svc) Test.@=? True
+
+test_manifestJsonRoundtrip :: Test.Tree
+test_manifestJsonRoundtrip =
+  Test.unit "manifest JSON roundtrip" <| do
+    now <- getCurrentTime
+    let manifest =
+          Manifest
+            { manifestVersion = 1,
+              manifestGeneration = now,
+              manifestServices =
+                [ Service
+                    { serviceName = "test-svc",
+                      serviceArtifact = Artifact "nix-closure" "/nix/store/abc123",
+                      serviceHosts = ["biz"],
+                      serviceExec = defaultExec,
+                      serviceEnv = mempty,
+                      serviceEnvFile = Nothing,
+                      serviceHttp = Just (Http "example.com" "/" 8000),
+                      serviceSystemd = defaultSystemd,
+                      serviceHardening = defaultHardening,
+                      serviceRevision = Nothing
+                    }
+                ]
+            }
+        encoded = Aeson.encode manifest
+    case Aeson.eitherDecode encoded of
+      Left err -> Test.assertFailure err
+      Right decoded -> do
+        length (manifestServices decoded) Test.@=? 1
+        case head <| manifestServices decoded of
+          Nothing -> Test.assertFailure "no services"
+          Just svc -> serviceName svc Test.@=? "test-svc"
+
+test_updateService :: Test.Tree
+test_updateService =
+  Test.unit "updateService updates store path" <| do
+    now <- getCurrentTime
+    let manifest =
+          Manifest
+            { manifestVersion = 1,
+              manifestGeneration = now,
+              manifestServices =
+                [ Service
+                    "svc-a"
+                    (Artifact "nix-closure" "/nix/store/old")
+                    ["biz"]
+                    defaultExec
+                    mempty
+                    Nothing
+                    Nothing
+                    defaultSystemd
+                    defaultHardening
+                    Nothing,
+                  Service
+                    "svc-b"
+                    (Artifact "nix-closure" "/nix/store/other")
+                    ["biz"]
+                    defaultExec
+                    mempty
+                    Nothing
+                    Nothing
+                    defaultSystemd
+                    defaultHardening
+                    Nothing
+                ]
+            }
+    case updateService "svc-a" "/nix/store/new" (Just "abc123") manifest of
+      Left err -> Test.assertFailure (Text.unpack err)
+      Right updated -> case head <| manifestServices updated of
+        Nothing -> Test.assertFailure "no services"
+        Just svcA -> do
+          storePath (serviceArtifact svcA) Test.@=? "/nix/store/new"
+          serviceRevision svcA Test.@=? Just "abc123"
+
+test_findService :: Test.Tree
+test_findService =
+  Test.unit "findService finds service by name" <| do
+    now <- getCurrentTime
+    let manifest =
+          Manifest
+            { manifestVersion = 1,
+              manifestGeneration = now,
+              manifestServices =
+                [ Service
+                    "svc-a"
+                    (Artifact "nix-closure" "/nix/store/a")
+                    ["biz"]
+                    defaultExec
+                    mempty
+                    Nothing
+                    Nothing
+                    defaultSystemd
+                    defaultHardening
+                    Nothing
+                ]
+            }
+    case findService "svc-a" manifest of
+      Nothing -> Test.assertFailure "service not found"
+      Just svc -> serviceName svc Test.@=? "svc-a"
+    case findService "nonexistent" manifest of
+      Nothing -> pure ()
+      Just _ -> Test.assertFailure "found nonexistent service"
+
+main :: IO ()
+main = Cli.main <| Cli.Plan help move test pure