path: root/Omni/Deploy/Manifest.hs

{-# 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