path: root/Omni/Deploy/Caddy.hs

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

-- | Caddy admin API integration for the mini-PaaS deployment system.
--
-- : out deploy-caddy
-- : dep aeson
-- : dep http-conduit
-- : dep http-types
module Omni.Deploy.Caddy
  ( buildRoute,
    getCurrentRoutes,
    upsertRoute,
    deleteRoute,
    syncRoutes,
    getRouteById,
    caddyAdmin,
    main,
    test,
  )
where

import Alpha
import Data.Aeson ((.=))
import qualified Data.Aeson as Aeson
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Network.HTTP.Simple as HTTP
import qualified Network.HTTP.Types.Status as Status
import Omni.Deploy.Manifest (Artifact (..), Exec (..), Hardening (..), Http (..), Service (..), Systemd (..))
import qualified Omni.Test as Test

caddyAdmin :: Text
caddyAdmin = "http://localhost:2019"

data Route = Route
  { routeId :: Text,
    routeMatch :: [RouteMatch],
    routeHandle :: [RouteHandler],
    routeTerminal :: Bool
  }
  deriving (Show, Eq, Generic)

instance Aeson.ToJSON Route where
  toJSON Route {..} =
    Aeson.object
      [ "@id" .= routeId,
        "match" .= routeMatch,
        "handle" .= routeHandle,
        "terminal" .= routeTerminal
      ]

newtype RouteMatch = RouteMatch
  { matchHost :: [Text]
  }
  deriving (Show, Eq, Generic)

instance Aeson.ToJSON RouteMatch where
  toJSON RouteMatch {..} =
    Aeson.object ["host" .= matchHost]

data RouteHandler = RouteHandler
  { handlerType :: Text,
    handlerUpstreams :: [Upstream]
  }
  deriving (Show, Eq, Generic)

instance Aeson.ToJSON RouteHandler where
  toJSON RouteHandler {..} =
    Aeson.object
      [ "handler" .= handlerType,
        "upstreams" .= handlerUpstreams
      ]

newtype Upstream = Upstream
  { upstreamDial :: Text
  }
  deriving (Show, Eq, Generic)

instance Aeson.ToJSON Upstream where
  toJSON Upstream {..} =
    Aeson.object ["dial" .= upstreamDial]

buildRoute :: Service -> Maybe Route
buildRoute Service {..} = case serviceHttp of
  Nothing -> Nothing
  Just Http {..} ->
    Just
      <| Route
        { routeId = "biz-" <> serviceName,
          routeMatch = [RouteMatch [httpDomain]],
          routeHandle =
            [ RouteHandler
                "reverse_proxy"
                [Upstream <| "localhost:" <> tshow httpInternalPort]
            ],
          routeTerminal = True
        }

getCurrentRoutes :: Text -> IO [Aeson.Value]
getCurrentRoutes adminUrl = do
  let url = Text.unpack adminUrl <> "/config/apps/http/servers/srv0/routes"
  request <- HTTP.parseRequest url
  result <- try @SomeException <| HTTP.httpLBS request
  case result of
    Left _ -> pure []
    Right response ->
      if Status.statusIsSuccessful (HTTP.getResponseStatus response)
        then case Aeson.decode (HTTP.getResponseBody response) of
          Just routes -> pure routes
          Nothing -> pure []
        else pure []

upsertRoute :: Text -> Service -> IO Bool
upsertRoute adminUrl svc = case buildRoute svc of
  Nothing -> pure False
  Just route -> do
    let routeId' = "biz-" <> serviceName svc
        patchUrl = Text.unpack adminUrl <> "/id/" <> Text.unpack routeId'
        postUrl = Text.unpack adminUrl <> "/config/apps/http/servers/srv0/routes"
        body = Aeson.encode route

    patchRequest <-
      HTTP.parseRequest patchUrl
        /> HTTP.setRequestMethod "PATCH"
        /> HTTP.setRequestBodyLBS body
        /> HTTP.setRequestHeader "Content-Type" ["application/json"]
    patchResult <- try @SomeException <| HTTP.httpLBS patchRequest

    case patchResult of
      Right resp
        | Status.statusIsSuccessful (HTTP.getResponseStatus resp) ->
            pure True
      _ -> do
        postRequest <-
          HTTP.parseRequest postUrl
            /> HTTP.setRequestMethod "POST"
            /> HTTP.setRequestBodyLBS body
            /> HTTP.setRequestHeader "Content-Type" ["application/json"]
        postResult <- try @SomeException <| HTTP.httpLBS postRequest
        case postResult of
          Right resp -> pure <| Status.statusIsSuccessful (HTTP.getResponseStatus resp)
          Left _ -> pure False

deleteRoute :: Text -> Text -> IO Bool
deleteRoute adminUrl serviceName' = do
  let routeId' = "biz-" <> serviceName'
      url = Text.unpack adminUrl <> "/id/" <> Text.unpack routeId'
  request <-
    HTTP.parseRequest url
      /> HTTP.setRequestMethod "DELETE"
  result <- try @SomeException <| HTTP.httpLBS request
  case result of
    Right resp -> pure <| Status.statusIsSuccessful (HTTP.getResponseStatus resp)
    Left _ -> pure False

syncRoutes :: Text -> [Service] -> IO (Map Text Bool)
syncRoutes adminUrl services = do
  results <-
    forM services <| \svc ->
      case serviceHttp svc of
        Nothing -> pure Nothing
        Just _ -> do
          success <- upsertRoute adminUrl svc
          pure <| Just (serviceName svc, success)
  pure <| Map.fromList <| catMaybes results

getRouteById :: Text -> Text -> IO (Maybe Aeson.Value)
getRouteById adminUrl routeId' = do
  let url = Text.unpack adminUrl <> "/id/" <> Text.unpack routeId'
  request <- HTTP.parseRequest url
  result <- try @SomeException <| HTTP.httpLBS request
  case result of
    Right resp
      | Status.statusIsSuccessful (HTTP.getResponseStatus resp) ->
          pure <| Aeson.decode (HTTP.getResponseBody resp)
    _ -> pure Nothing

test :: Test.Tree
test =
  Test.group
    "Omni.Deploy.Caddy"
    [ test_buildRouteWithHttp,
      test_buildRouteWithoutHttp,
      test_buildRouteWithPath
    ]

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

test_buildRouteWithHttp :: Test.Tree
test_buildRouteWithHttp =
  Test.unit "builds route for service with HTTP" <| do
    let svc = mkTestService "test-svc" "/nix/store/abc" (Just <| Http "example.com" "/" 8000)
    case buildRoute svc of
      Nothing -> Test.assertFailure "expected route"
      Just route -> do
        routeId route Test.@=? "biz-test-svc"
        case (head <| routeMatch route, head <| routeHandle route) of
          (Just m, Just h) -> do
            matchHost m Test.@=? ["example.com"]
            case head <| handlerUpstreams h of
              Just u -> upstreamDial u Test.@=? "localhost:8000"
              Nothing -> Test.assertFailure "no upstreams"
          _ -> Test.assertFailure "no match/handle"

test_buildRouteWithoutHttp :: Test.Tree
test_buildRouteWithoutHttp =
  Test.unit "returns Nothing for service without HTTP" <| do
    let svc = mkTestService "worker" "/nix/store/xyz" Nothing
    case buildRoute svc of
      Nothing -> pure ()
      Just _ -> Test.assertFailure "expected Nothing"

test_buildRouteWithPath :: Test.Tree
test_buildRouteWithPath =
  Test.unit "builds route with custom path" <| do
    let svc = mkTestService "api" "/nix/store/abc" (Just <| Http "api.example.com" "/v1" 8080)
    case buildRoute svc of
      Nothing -> Test.assertFailure "expected route"
      Just route -> case head <| routeMatch route of
        Nothing -> Test.assertFailure "no match"
        Just m -> matchHost m Test.@=? ["api.example.com"]

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