1 files changed, 241 insertions, 0 deletions
diff --git a/Omni/Deploy/Caddy.hs b/Omni/Deploy/Caddy.hs
new file mode 100644
index 0000000..6cedf92
--- /dev/null
+++ b/Omni/Deploy/Caddy.hs
@@ -0,0 +1,241 @@
+{-# 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