buzzctl

default.nix

{ lib, pkgs, ... }:
let
  haskellLibs = ps: with ps; [
    optparse-applicative
    regex-tdfa
    raw-strings-qq
    extra
    string-interpolate
    ansi-terminal
    aeson
  ];

  runtimeDependencies = with pkgs; [
    gitversion
    yq-go
    git-cliff
  ];

  runtimeEnv = pkgs.buildEnv {
    name = "runtimeEnv";
    paths = runtimeDependencies;
  };

  package = pkgs.writers.writeHaskellBin
    "buzzctl"
    {
      libraries = haskellLibs (pkgs.haskellPackages);
      makeWrapperArgs = [
        "--prefix"
        "PATH"
        ":"
        "${runtimeEnv}/bin"
      ];
    }
    (lib.readFile ./main.hs);

  devShell = pkgs.mkShell {
    buildInputs = [
      (pkgs.haskellPackages.ghcWithPackages haskellLibs)
      runtimeEnv
    ];
  };
in
{
  inherit package devShell;
}

main.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Use newtype instead of data" #-}

import Control.Monad
import Control.Monad.RWS.CPS (MonadState (put))
import Data.Aeson (FromJSON (parseJSON), Options (fieldLabelModifier), decode, defaultOptions, genericParseJSON, withObject, (.:), (.:?))
import Data.Aeson.Types (camelTo)
import Data.ByteString.Lazy.Char8 qualified as BL
import Data.Char (isSpace, toUpper)
import Data.Data (Data)
import Data.List (dropWhileEnd)
import Data.List.Extra (dropSuffix, split)
import Data.String (fromString)
import Data.String.Interpolate (i)
import GHC.Generics
import Options.Applicative
import System.Console.ANSI
import System.Directory
import System.Environment (getEnv)
import System.Process
import Text.RawString.QQ
import Text.Regex.TDFA ((=~))
import Text.Regex.TDFA qualified

data PromoteOptions = PromoteOptions {allowDirty :: Bool, noPush :: Bool}
data Command = App AppCommand | Database DatabaseCommand | Promote PromoteOptions
data AppCommand = SecretsUnlock | SecretsUpdate
data DatabaseCommand = Proxy

buzzctl :: Parser Command
buzzctl =
    hsubparser (command "app" (info appCommand (fullDesc <> progDesc "Manage the app")))
        <|> hsubparser (command "database" (info databaseCommand (fullDesc <> progDesc "Manage the database")))
        <|> hsubparser (command "promote" (info (Promote <$> promoteCommand) (fullDesc <> progDesc "Promote main branch to the production.")))

appCommand :: Parser Command
appCommand =
    App
        <$> hsubparser
            ( command "secrets" (info secretsCommand (fullDesc <> progDesc "Manage secrets for the app"))
            )

secretsCommand :: Parser AppCommand
secretsCommand =
    hsubparser
        ( command "unlock" (info (pure SecretsUnlock) (fullDesc <> progDesc "Unlock secrets"))
            <> command "update" (info (pure SecretsUpdate) (fullDesc <> progDesc "Update secrets"))
            <> help "Update/Unlock secrets by encrypting from or to the .env* files in the app directory."
        )

databaseCommand :: Parser Command
databaseCommand = Database <$> hsubparser (command "proxy" (info (pure Proxy) (fullDesc <> progDesc "Start the database proxy connect to google cloud sql instance via iam.")))

promoteCommand :: Parser PromoteOptions
promoteCommand =
    PromoteOptions
        <$> switch (long "allow-dirty" <> help "Allow dirty working directory.")
        <*> switch (long "no-push" <> help "Do not push the changes to the remote. So all changes stay local. Will also disable vercel promotion.")

main :: IO ()
main = do
    buzzCommand <- customExecParser p opts
    rootDir <- getEnv "DEVENV_ROOT"
    case buzzCommand of
        App SecretsUnlock -> unlockSecrets (rootDir ++ "/app")
        App SecretsUpdate -> updateSecrets (rootDir ++ "/app")
        Database Proxy -> proxyDatabase
        Promote options -> executePromotion options
  where
    opts = info (buzzctl <**> helper) fullDesc
    p = prefs $ showHelpOnEmpty <> showHelpOnError

unlockSecrets :: String -> IO ()
unlockSecrets appDir = do
    putStrLn "Unlocking secrets..."
    files <- listDirectory appDir

    forM_ (selectEncodedFiles files) $ \file -> do
        putStrLn $ "Unlocking " ++ file
        let encodedFile = appDir ++ "/" ++ file
        let decodedFile = dropSuffix ".enc.yaml" encodedFile
        putStrLn [i|Decoding #{encodedFile} to #{decodedFile}|]
        callCommand [i|sops --decrypt --output-type dotenv #{encodedFile} > #{decodedFile}|]
  where
    selectEncodedFiles :: [String] -> [String]
    selectEncodedFiles = filter (=~ encodedFilePattern)
    encodedFilePattern :: String
    encodedFilePattern = [r|^\.env\.[[:alpha:]]+\.local\.enc\.yaml$|]

updateSecrets :: String -> IO ()
updateSecrets appDir = do
    putStrLn "Updating secrets..."
    files <- listDirectory appDir

    forM_ (selectDecodedFiles files) $ \file -> do
        putStrLn $ "Updating " ++ file
        let decodedFile = appDir ++ "/" ++ file
        let encodedFile = decodedFile ++ ".enc.yaml"
        putStrLn [i|Encoding #{decodedFile} to #{encodedFile}|]
        callCommand [i|sops --encrypt --input-type dotenv #{decodedFile} > #{encodedFile}|]
  where
    selectDecodedFiles :: [String] -> [String]
    selectDecodedFiles = filter (=~ decodedFilePattern)
    decodedFilePattern :: String
    decodedFilePattern = [r|^\.env\.[[:alpha:]]+\.local$|]

proxyDatabase :: IO ()
proxyDatabase = do
    dbinstance <- getEnv "BUZZAR_DB_INSTANCE"
    stateDir <- getEnv "DEVENV_STATE"
    let backendServiceAccount = "buzzar-backend@buzzar-c241.iam.gserviceaccount.com" :: String
    let postgresUsername = dropSuffix ".gserviceaccount.com" backendServiceAccount
    let workingDir = stateDir ++ "/" ++ "cloud-sql-proxy"
    createDirectoryIfMissing True workingDir

    putStrLn "Starting database proxy..."
    putStrLn [i|Database instance: #{dbinstance}|]
    logWarn "Make sure the database instance has a public ip address, which is disabled by default! Enable it in `/infrastructure/database-instance.tf`"
    logWarn "Connect to the database via for example:"
    putStrLn [i|psql "host=127.0.0.1 sslmode=disable dbname=buzzar-v2-staging user=#{postgresUsername}"|]
    setSGR [Reset]

    let credentialsFile = workingDir ++ "/credentials.json"
    callCommand [i|gcloud iam service-accounts keys create #{credentialsFile} --iam-account=#{backendServiceAccount}|]
    callCommand [i|cloud-sql-proxy --credentials-file #{credentialsFile} #{dbinstance} --auto-iam-authn|]

executePromotion :: PromoteOptions -> IO ()
executePromotion PromoteOptions{..} = do
    rootDir <- getEnv "DEVENV_ROOT"
    let imageSelectFile = rootDir ++ "/k8s/overlays/production/image-select.yaml"

    putStrLn "Promoting main branch to production..."
    -- 1. Assert that the current branch is main.
    branch <- currentBranch
    assertBranch branch "main"

    -- 2. Assert that the working directory is clean.
    isDirty <- isDirty
    assertCleanWorkingDirectory allowDirty isDirty

    -- 3. Assert that the remote main branch is up-to-date.
    assertBranchIsUpToDate

    -- 4. tag the current commit with the semver from gitversion
    VersionInfo{..} <- getGitVersion

    -- 5. Set spec.policy.semver.range to the new semver ^{major}.x in $DEVENV_ROOT/k8s/overlays/production/image-select.yaml via yq
    putStrLn [i|Patching production to #{major}|]
    callCommand [i|yq --inplace '(select(.spec.policy.semver.range) | .spec.policy.semver.range) = "^#{major}.x"' #{imageSelectFile}|]
    fileChanged <- fileChanged imageSelectFile
    when fileChanged $ do
        callCommand [i|git add #{imageSelectFile}|]
        callCommand [i|git commit -m "⏫ Patch production to #{major}"|]

    -- 6. Generate a changelog from the last tag to the current commit
    let changelogFile = rootDir ++ "/CHANGELOG.md"
    generateChangelog changelogFile semVer
    callCommand [i|git add #{changelogFile}|]
    callCommand [i|git commit -m "🏆 Promote production to v#{semVer}"|]
    callCommand [i|git tag v#{semVer}|]

    callCommand [i|git switch release|]
    assertBranchIsUpToDate

    -- 7. Merge main to release ff-only
    callCommand [i|git merge main --ff-only|]
    callCommand [i|git switch main|]

    unless noPush $ do
        -- 8. Push the tag and the updated branches to the remote
        callCommand [i|git push origin v#{semVer}|]
        callCommand [i|git push origin main|]
        callCommand [i|git push origin release|]
  where
    assertBranch :: String -> String -> IO ()
    assertBranch current target = do
        if current == target
            then return ()
            else error [i|You can only promote from the #{target} branch. You are currently on #{current}.|]

    currentBranch :: IO String
    currentBranch = strip <$> readProcess "git" ["rev-parse", "--abbrev-ref", "HEAD"] ""

    isDirty :: IO Bool
    isDirty = do
        status <- readProcess "git" ["status", "--porcelain"] ""
        return $ status /= ""

    fileChanged :: String -> IO Bool
    fileChanged file = do
        status <- readProcess "git" ["status", "--porcelain", file] ""
        return $ status /= ""

    currentSha :: IO String
    currentSha = strip <$> readProcess "git" ["rev-parse", "HEAD"] ""

    assertCleanWorkingDirectory :: Bool -> Bool -> IO ()
    assertCleanWorkingDirectory allowDirty isDirty = do
        if not isDirty
            then return ()
            else
                if allowDirty
                    then logWarn "Working directory is dirty, but continuing anyway."
                    else error "You have uncommitted changes in your working directory."

    assertBranchIsUpToDate :: IO ()
    assertBranchIsUpToDate = do
        branch <- currentBranch
        localRev <- strip <$> readProcess "git" ["rev-parse", branch] ""
        remoteRev <- strip <$> readProcess "git" ["rev-parse", [i|origin/#{branch}|]] ""
        if localRev == remoteRev
            then return ()
            else error "Your local branch is not up-to-date with the remote branch."

    generateChangelog :: String -> String -> IO ()
    generateChangelog changelogFile semver = callCommand [i|git cliff --output #{changelogFile} --tag #{semver} |]

    getGitVersion :: IO VersionInfo
    getGitVersion = do
        gitversion <- readProcess "gitversion" [] ""
        let versionInfo = decode (BL.pack gitversion) :: Maybe VersionInfo
        case versionInfo of
            Just info -> return info
            Nothing -> error "Could not parse gitversion output."

logWithColor :: Color -> String -> IO ()
logWithColor color str = do
    setSGR [SetColor Foreground Dull color]
    putStrLn str
    setSGR [Reset]

logWarn :: String -> IO ()
logWarn = logWithColor Yellow

logError :: String -> IO ()
logError = logWithColor Red

strip :: String -> String
strip = dropWhileEnd isSpace . dropWhile isSpace

-- | Get the version info from gitversion
data VersionInfo = VersionInfo
    { major :: Int
    , minor :: Int
    , patch :: Int
    , semVer :: String
    , branchName :: String
    , escapedBranchName :: String
    , sha :: String
    , shortSha :: String
    , commitDate :: String
    }
    deriving (Show, Generic)

instance FromJSON VersionInfo where
    parseJSON =
        genericParseJSON $
            defaultOptions
                { fieldLabelModifier = toCamelCase
                }
      where
        toCamelCase :: String -> String
        toCamelCase (x : xs) = toUpper x : xs