path: root/Omni/Deploy/Systemd.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- | Systemd unit file generator for the mini-PaaS deployment system.
--
-- : out deploy-systemd
-- : dep directory
module Omni.Deploy.Systemd
  ( generateUnit,
    writeUnit,
    createSymlink,
    reloadAndRestart,
    stopAndDisable,
    removeUnit,
    getRunningStorePath,
    servicesDir,
    main,
    test,
  )
where

import Alpha
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import Omni.Deploy.Manifest (Artifact (..), Exec (..), Hardening (..), Service (..), Systemd (..))
import qualified Omni.Test as Test
import qualified System.Directory as Dir
import System.FilePath ((</>))
import qualified System.Process as Process

servicesDir :: FilePath
servicesDir = "/var/lib/biz-deployer/services"

generateUnit :: Service -> Text
generateUnit Service {..} =
  Text.unlines <| unitSection ++ serviceSection ++ hardeningSection ++ installSection
  where
    binary = fromMaybe serviceName (execCommand serviceExec)
    execStart = storePath serviceArtifact <> "/bin/" <> binary

    unitSection =
      [ "[Unit]",
        "Description=" <> serviceName,
        "After=" <> Text.intercalate " " (systemdAfter serviceSystemd)
      ]
        ++ requiresLine

    requiresLine =
      ["Requires=" <> Text.intercalate " " (systemdRequires serviceSystemd) | not (null (systemdRequires serviceSystemd))]

    serviceSection =
      [ "",
        "[Service]",
        "Type=simple",
        "ExecStart=" <> execStart,
        "User=" <> execUser serviceExec,
        "Group=" <> execGroup serviceExec,
        "Restart=" <> systemdRestart serviceSystemd,
        "RestartSec=" <> tshow (systemdRestartSec serviceSystemd)
      ]
        ++ envLines
        ++ envFileLine

    envLines =
      Map.toList serviceEnv
        |> map (\(k, v) -> "Environment=\"" <> k <> "=" <> v <> "\"")

    envFileLine = case serviceEnvFile of
      Nothing -> []
      Just path -> ["EnvironmentFile=" <> path]

    hardeningSection =
      [ "",
        "# Hardening",
        "PrivateTmp=" <> boolToYesNo (hardeningPrivateTmp serviceHardening),
        "ProtectSystem=" <> hardeningProtectSystem serviceHardening,
        "ProtectHome=" <> boolToYesNo (hardeningProtectHome serviceHardening),
        "NoNewPrivileges=yes"
      ]
        ++ readWritePathsLine

    readWritePathsLine =
      case Map.lookup "DATA_DIR" serviceEnv of
        Just dataDir -> ["ReadWritePaths=" <> dataDir]
        Nothing -> []

    installSection =
      [ "",
        "[Install]",
        "WantedBy=multi-user.target"
      ]

    boolToYesNo True = "yes"
    boolToYesNo False = "no"

writeUnit :: FilePath -> Service -> IO FilePath
writeUnit baseDir svc = do
  Dir.createDirectoryIfMissing True baseDir
  let path = baseDir </> Text.unpack (serviceName svc) <> ".service"
      content = generateUnit svc
  Text.IO.writeFile path content
  pure path

createSymlink :: FilePath -> FilePath -> Service -> IO FilePath
createSymlink baseDir sysDir svc = do
  let unitPath = baseDir </> Text.unpack (serviceName svc) <> ".service"
      linkPath = sysDir </> Text.unpack (serviceName svc) <> ".service"
  exists <- Dir.doesPathExist linkPath
  when exists <| Dir.removeFile linkPath
  Dir.createFileLink unitPath linkPath
  pure linkPath

reloadAndRestart :: Text -> IO ()
reloadAndRestart serviceName' = do
  _ <- Process.readProcessWithExitCode "systemctl" ["daemon-reload"] ""
  _ <-
    Process.readProcessWithExitCode
      "systemctl"
      ["enable", "--now", Text.unpack serviceName' <> ".service"]
      ""
  pure ()

stopAndDisable :: Text -> IO ()
stopAndDisable serviceName' = do
  _ <-
    Process.readProcessWithExitCode
      "systemctl"
      ["disable", "--now", Text.unpack serviceName' <> ".service"]
      ""
  pure ()

removeUnit :: FilePath -> FilePath -> Text -> IO ()
removeUnit baseDir sysDir serviceName' = do
  let unitPath = baseDir </> Text.unpack serviceName' <> ".service"
      linkPath = sysDir </> Text.unpack serviceName' <> ".service"
  linkExists <- Dir.doesPathExist linkPath
  when linkExists <| Dir.removeFile linkPath
  unitExists <- Dir.doesPathExist unitPath
  when unitExists <| Dir.removeFile unitPath
  _ <- Process.readProcessWithExitCode "systemctl" ["daemon-reload"] ""
  pure ()

-- | Get the store path of the currently running service by reading its unit file.
getRunningStorePath :: Text -> IO (Maybe Text)
getRunningStorePath serviceName' = do
  let unitPath = servicesDir </> Text.unpack serviceName' <> ".service"
  exists <- Dir.doesFileExist unitPath
  if not exists
    then pure Nothing
    else do
      content <- Text.IO.readFile unitPath
      pure <| extractStorePath content
  where
    -- Extract /nix/store/...-service-name from ExecStart=/nix/store/.../bin/...
    extractStorePath content =
      content
        |> Text.lines
        |> find (Text.isPrefixOf "ExecStart=")
        |> fmap (Text.drop (Text.length "ExecStart="))
        |> fmap (Text.dropWhile (/= '/'))
        |> fmap (Text.drop 1)
        |> fmap (Text.takeWhile (/= '/'))
        |> fmap ("/nix/store/" <>)

test :: Test.Tree
test =
  Test.group
    "Omni.Deploy.Systemd"
    [ test_generateBasicUnit,
      test_generateUnitWithEnv,
      test_generateUnitWithCustomExec,
      test_generateUnitWithEnvFile,
      test_generateUnitWithDependencies,
      test_generateUnitWithHardening
    ]

mkTestService :: Text -> Text -> Service
mkTestService name path =
  Service
    { serviceName = name,
      serviceArtifact = Artifact "nix-closure" path,
      serviceHosts = ["biz"],
      serviceExec = Exec Nothing "root" "root",
      serviceEnv = mempty,
      serviceEnvFile = Nothing,
      serviceHttp = Nothing,
      serviceSystemd = Systemd ["network-online.target"] [] "on-failure" 5,
      serviceHardening = Hardening False True "strict" True,
      serviceRevision = Nothing
    }

test_generateBasicUnit :: Test.Tree
test_generateBasicUnit =
  Test.unit "generates basic unit file" <| do
    let svc = mkTestService "test-service" "/nix/store/abc123-test"
        unit = generateUnit svc
    Text.isInfixOf "[Unit]" unit Test.@=? True
    Text.isInfixOf "Description=test-service" unit Test.@=? True
    Text.isInfixOf "[Service]" unit Test.@=? True
    Text.isInfixOf "ExecStart=/nix/store/abc123-test/bin/test-service" unit Test.@=? True
    Text.isInfixOf "[Install]" unit Test.@=? True
    Text.isInfixOf "WantedBy=multi-user.target" unit Test.@=? True

test_generateUnitWithEnv :: Test.Tree
test_generateUnitWithEnv =
  Test.unit "generates unit with environment" <| do
    let svc =
          (mkTestService "env-test" "/nix/store/xyz")
            { serviceEnv = Map.fromList [("PORT", "8000"), ("DEBUG", "true")]
            }
        unit = generateUnit svc
    Text.isInfixOf "Environment=\"PORT=8000\"" unit Test.@=? True
    Text.isInfixOf "Environment=\"DEBUG=true\"" unit Test.@=? True

test_generateUnitWithCustomExec :: Test.Tree
test_generateUnitWithCustomExec =
  Test.unit "generates unit with custom exec" <| do
    let svc =
          (mkTestService "custom-exec" "/nix/store/abc")
            { serviceExec = Exec (Just "my-binary") "www-data" "www-data"
            }
        unit = generateUnit svc
    Text.isInfixOf "ExecStart=/nix/store/abc/bin/my-binary" unit Test.@=? True
    Text.isInfixOf "User=www-data" unit Test.@=? True
    Text.isInfixOf "Group=www-data" unit Test.@=? True

test_generateUnitWithEnvFile :: Test.Tree
test_generateUnitWithEnvFile =
  Test.unit "generates unit with env file" <| do
    let svc =
          (mkTestService "env-file-test" "/nix/store/xyz")
            { serviceEnvFile = Just "/var/lib/biz-secrets/test.env"
            }
        unit = generateUnit svc
    Text.isInfixOf "EnvironmentFile=/var/lib/biz-secrets/test.env" unit Test.@=? True

test_generateUnitWithDependencies :: Test.Tree
test_generateUnitWithDependencies =
  Test.unit "generates unit with dependencies" <| do
    let svc =
          (mkTestService "dep-test" "/nix/store/abc")
            { serviceSystemd =
                Systemd
                  ["network-online.target", "postgresql.service"]
                  ["postgresql.service"]
                  "on-failure"
                  5
            }
        unit = generateUnit svc
    Text.isInfixOf "After=network-online.target postgresql.service" unit Test.@=? True
    Text.isInfixOf "Requires=postgresql.service" unit Test.@=? True

test_generateUnitWithHardening :: Test.Tree
test_generateUnitWithHardening =
  Test.unit "generates unit with hardening" <| do
    let svc =
          (mkTestService "hardened" "/nix/store/abc")
            { serviceHardening = Hardening False True "full" True
            }
        unit = generateUnit svc
    Text.isInfixOf "PrivateTmp=yes" unit Test.@=? True
    Text.isInfixOf "ProtectSystem=full" unit Test.@=? True
    Text.isInfixOf "ProtectHome=yes" unit Test.@=? True
    Text.isInfixOf "NoNewPrivileges=yes" unit Test.@=? True

main :: IO ()
main = Test.run test