feat: add v2 hub and widget create endpoints

2026-05-16 08:34:20 +02:00
parent 0a4646bf44
commit 4ebc04e1f4
11 changed files with 536 additions and 154 deletions
--- a/Web/Controller/Api/V2/Hubs.hs
+++ b/Web/Controller/Api/V2/Hubs.hs
@@ -0,0 +1,112 @@
+module Web.Controller.Api.V2.Hubs where
+
+import Web.Types
+import Generated.Types
+import IHP.Prelude
+import IHP.ControllerPrelude
+import Data.Aeson (Value, object, (.=))
+import Network.Wai (requestMethod)
+import Web.Controller.Api.V2.Auth
+    ( requireApiConsumer, paginatedResponse, getPageParams
+    , respondWithStatus )
+
+instance Controller ApiV2HubsController where
+
+    action ApiV2IndexHubsAction = do
+        case requestMethod ?request of
+            "GET"  -> listHubs
+            "POST" -> createHub
+            _      -> respondWithStatus 405 $ object ["error" .= ("Method not allowed" :: Text)]
+
+    action ApiV2ShowHubAction { hubId } = do
+        _consumer <- requireApiConsumer
+        hub <- fetch hubId
+        renderJson (hubToJson hub)
+
+    action ApiV2CreateHubAction = createHub
+
+listHubs :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO ()
+listHubs = do
+    _consumer <- requireApiConsumer
+    (page, perPage) <- getPageParams
+    let pageOffset = (page - 1) * perPage
+    total <- query @Hub |> fetchCount
+    hubs <- query @Hub
+        |> orderByAsc #name
+        |> limit perPage
+        |> offset pageOffset
+        |> fetch
+    renderJson $ paginatedResponse (map hubToJson hubs) page perPage total
+
+createHub :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO ()
+createHub = do
+    _consumer <- requireApiConsumer
+    let slug   = paramOrNothing @Text "slug"
+        name   = paramOrNothing @Text "name"
+        domain = paramOrNothing @Text "domain"
+        kind   = fromMaybe "domain" (nonEmptyText =<< paramOrNothing @Text "hubKind")
+
+    let missing = missingRequiredFields
+            [ ("slug", slug)
+            , ("name", name)
+            , ("domain", domain)
+            ]
+    unless (null missing) do
+        respondWithStatus 422 $ object
+            [ "error"   .= ("Missing required fields" :: Text)
+            , "missing" .= missing
+            ]
+
+    unless (validCreateHubKind kind) do
+        respondWithStatus 422 $ object
+            [ "error" .= ("Unsupported hubKind" :: Text)
+            , "code"  .= ("unsupported_hub_kind" :: Text)
+            , "value" .= kind
+            , "valid" .= validCreateHubKinds
+            ]
+
+    let Just slugText   = slug
+        Just nameText   = name
+        Just domainText = domain
+
+    existing <- query @Hub
+        |> filterWhere (#slug, slugText)
+        |> fetchOneOrNothing
+    when (isJust existing) do
+        respondWithStatus 422 $ object
+            [ "error" .= ("Hub slug already exists" :: Text)
+            , "code"  .= ("duplicate_hub_slug" :: Text)
+            , "value" .= slugText
+            ]
+
+    hub <- newRecord @Hub
+        |> set #slug slugText
+        |> set #name nameText
+        |> set #domain domainText
+        |> set #hubKind kind
+        |> createRecord
+    respondWithStatus 201 (hubToJson hub)
+
+hubToJson :: Hub -> Value
+hubToJson hub = object
+    [ "id"        .= hub.id
+    , "slug"      .= hub.slug
+    , "name"      .= hub.name
+    , "domain"    .= hub.domain
+    , "hubKind"   .= hub.hubKind
+    , "createdAt" .= hub.createdAt
+    ]
+
+validCreateHubKinds :: [Text]
+validCreateHubKinds = ["domain", "shared"]
+
+validCreateHubKind :: Text -> Bool
+validCreateHubKind kind = kind `elem` validCreateHubKinds
+
+missingRequiredFields :: [(Text, Maybe Text)] -> [Text]
+missingRequiredFields fields =
+    [ name | (name, value) <- fields, maybe True (== "") value ]
+
+nonEmptyText :: Text -> Maybe Text
+nonEmptyText "" = Nothing
+nonEmptyText value = Just value