generated from coulomb/repo-seed
feat: add v2 manifest bootstrap endpoints
Some checks failed
Build and Deploy / build-push-deploy (push) Has been cancelled
Some checks failed
Build and Deploy / build-push-deploy (push) Has been cancelled
This commit is contained in:
264
Web/Controller/Api/V2/HubCapabilityManifests.hs
Normal file
264
Web/Controller/Api/V2/HubCapabilityManifests.hs
Normal file
@@ -0,0 +1,264 @@
|
||||
module Web.Controller.Api.V2.HubCapabilityManifests where
|
||||
|
||||
import Web.Types
|
||||
import Generated.Types
|
||||
import IHP.Prelude
|
||||
import IHP.ControllerPrelude
|
||||
import Data.Aeson (Value(..), object, toJSON, (.=))
|
||||
import IHP.ControllerSupport (getHeader, requestBodyJSON)
|
||||
import Network.Wai (requestMethod)
|
||||
import Web.Controller.Api.V2.Auth
|
||||
( requireApiConsumer, paginatedResponse, getPageParams
|
||||
, respondWithStatus )
|
||||
import Control.Monad (void)
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Data.String (fromString)
|
||||
import qualified Data.Aeson.Key as K
|
||||
import qualified Data.Aeson.KeyMap as KM
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.UUID as UUID
|
||||
import qualified Data.Vector as V
|
||||
import Database.PostgreSQL.Simple (Only(..))
|
||||
|
||||
instance Controller ApiV2HubCapabilityManifestsController where
|
||||
|
||||
action ApiV2IndexHubCapabilityManifestsAction = do
|
||||
case requestMethod ?request of
|
||||
"GET" -> listManifests
|
||||
"POST" -> createManifest
|
||||
_ -> respondWithStatus 405 $ object ["error" .= ("Method not allowed" :: Text)]
|
||||
|
||||
action ApiV2ShowHubCapabilityManifestAction { hubCapabilityManifestId } = do
|
||||
case requestMethod ?request of
|
||||
"GET" -> showManifest hubCapabilityManifestId
|
||||
"PATCH" -> updateManifest hubCapabilityManifestId
|
||||
_ -> respondWithStatus 405 $ object ["error" .= ("Method not allowed" :: Text)]
|
||||
|
||||
action ApiV2CreateHubCapabilityManifestAction = createManifest
|
||||
|
||||
action ApiV2UpdateHubCapabilityManifestAction { hubCapabilityManifestId } =
|
||||
updateManifest hubCapabilityManifestId
|
||||
|
||||
action ApiV2ActivateHubCapabilityManifestAction { hubCapabilityManifestId } = do
|
||||
when (requestMethod ?request /= "POST") do
|
||||
respondWithStatus 405 $ object ["error" .= ("Method not allowed" :: Text)]
|
||||
activateManifest hubCapabilityManifestId
|
||||
|
||||
listManifests :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO ()
|
||||
listManifests = do
|
||||
_consumer <- requireApiConsumer
|
||||
(page, perPage) <- getPageParams
|
||||
let pageOffset = (page - 1) * perPage
|
||||
mHubId = paramOrNothing @(Id Hub) "hubId"
|
||||
mStatus = paramOrNothing @Text "status"
|
||||
baseQ = query @HubCapabilityManifest |> orderByDesc #createdAt
|
||||
q1 = case mHubId of
|
||||
Just hubId -> baseQ |> filterWhere (#hubId, hubId)
|
||||
Nothing -> baseQ
|
||||
q2 = case mStatus of
|
||||
Just status -> q1 |> filterWhere (#status, status)
|
||||
Nothing -> q1
|
||||
total <- q2 |> fetchCount
|
||||
manifests <- q2
|
||||
|> limit perPage
|
||||
|> offset pageOffset
|
||||
|> fetch
|
||||
renderJson $ paginatedResponse (map manifestToJson manifests) page perPage total
|
||||
|
||||
showManifest :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Id HubCapabilityManifest -> IO ()
|
||||
showManifest manifestId = do
|
||||
_consumer <- requireApiConsumer
|
||||
manifest <- fetch manifestId
|
||||
renderJson (manifestToJson manifest)
|
||||
|
||||
createManifest :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO ()
|
||||
createManifest = do
|
||||
_consumer <- requireApiConsumer
|
||||
let hubIdText = paramOrNothing @Text "hubId"
|
||||
manifestVersion = fromMaybe "1.0" (nonEmptyText =<< paramOrNothing @Text "manifestVersion")
|
||||
capabilityDescription = paramOrNothing @Text "capabilityDescription"
|
||||
contact = paramOrNothing @Text "contact"
|
||||
|
||||
when (maybe True (== "") hubIdText) do
|
||||
respondWithStatus 422 $ object
|
||||
[ "error" .= ("Missing required fields" :: Text)
|
||||
, "missing" .= (["hubId"] :: [Text])
|
||||
]
|
||||
|
||||
let Just rawHubId = hubIdText
|
||||
case UUID.fromText rawHubId of
|
||||
Nothing -> respondWithStatus 422 $ object
|
||||
["error" .= ("hubId must be a valid UUID" :: Text)]
|
||||
Just rawId -> do
|
||||
let hubId = Id rawId :: Id Hub
|
||||
mHub <- fetchOneOrNothing hubId
|
||||
case mHub of
|
||||
Nothing -> respondWithStatus 422 $ object ["error" .= ("Hub not found" :: Text)]
|
||||
Just _hub -> do
|
||||
existing <- query @HubCapabilityManifest
|
||||
|> filterWhere (#hubId, hubId)
|
||||
|> fetchOneOrNothing
|
||||
when (isJust existing) do
|
||||
respondWithStatus 422 $ object
|
||||
[ "error" .= ("Hub already has a capability manifest" :: Text)
|
||||
, "code" .= ("manifest_already_exists" :: Text)
|
||||
]
|
||||
manifest <- newRecord @HubCapabilityManifest
|
||||
|> set #hubId hubId
|
||||
|> set #manifestVersion manifestVersion
|
||||
|> set #declaredWidgetTypes (toJSON (textArrayFieldFromRequestOrEmpty "declaredWidgetTypes"))
|
||||
|> set #declaredEventTypes (toJSON (textArrayFieldFromRequestOrEmpty "declaredEventTypes"))
|
||||
|> set #declaredAnnotationCategories (toJSON (textArrayFieldFromRequestOrEmpty "declaredAnnotationCategories"))
|
||||
|> set #declaredPolicyScopes (toJSON (textArrayFieldFromRequestOrEmpty "declaredPolicyScopes"))
|
||||
|> set #capabilityDescription capabilityDescription
|
||||
|> set #contact contact
|
||||
|> set #status "draft"
|
||||
|> createRecord
|
||||
respondWithStatus 201 (manifestToJson manifest)
|
||||
|
||||
updateManifest :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Id HubCapabilityManifest -> IO ()
|
||||
updateManifest manifestId = do
|
||||
_consumer <- requireApiConsumer
|
||||
manifest <- fetch manifestId
|
||||
unless (manifest.status == "draft") do
|
||||
respondWithStatus 422 $ object
|
||||
[ "error" .= ("Active manifests are read-only" :: Text)
|
||||
, "code" .= ("manifest_read_only" :: Text)
|
||||
]
|
||||
|
||||
let manifestVersion = fromMaybe manifest.manifestVersion (nonEmptyText =<< paramOrNothing @Text "manifestVersion")
|
||||
capabilityDescription = fromMaybe manifest.capabilityDescription (Just <$> paramOrNothing @Text "capabilityDescription")
|
||||
contact = fromMaybe manifest.contact (Just <$> paramOrNothing @Text "contact")
|
||||
declaredWidgetTypes = maybe manifest.declaredWidgetTypes toJSON (textArrayFieldFromRequest "declaredWidgetTypes")
|
||||
declaredEventTypes = maybe manifest.declaredEventTypes toJSON (textArrayFieldFromRequest "declaredEventTypes")
|
||||
declaredAnnotationCategories = maybe manifest.declaredAnnotationCategories toJSON (textArrayFieldFromRequest "declaredAnnotationCategories")
|
||||
declaredPolicyScopes = maybe manifest.declaredPolicyScopes toJSON (textArrayFieldFromRequest "declaredPolicyScopes")
|
||||
|
||||
manifest <- manifest
|
||||
|> set #manifestVersion manifestVersion
|
||||
|> set #declaredWidgetTypes declaredWidgetTypes
|
||||
|> set #declaredEventTypes declaredEventTypes
|
||||
|> set #declaredAnnotationCategories declaredAnnotationCategories
|
||||
|> set #declaredPolicyScopes declaredPolicyScopes
|
||||
|> set #capabilityDescription capabilityDescription
|
||||
|> set #contact contact
|
||||
|> updateRecord
|
||||
renderJson (manifestToJson manifest)
|
||||
|
||||
activateManifest :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Id HubCapabilityManifest -> IO ()
|
||||
activateManifest manifestId = do
|
||||
_consumer <- requireApiConsumer
|
||||
manifest <- fetch manifestId
|
||||
when (manifest.status == "active") do
|
||||
respondWithStatus 200 (manifestToJson manifest)
|
||||
when (manifest.status == "retired") do
|
||||
respondWithStatus 422 $ object
|
||||
[ "error" .= ("Retired manifests cannot be activated" :: Text)
|
||||
, "code" .= ("manifest_retired" :: Text)
|
||||
]
|
||||
|
||||
hub <- fetch manifest.hubId
|
||||
let wTypes = jsonArrayTexts manifest.declaredWidgetTypes
|
||||
eTypes = jsonArrayTexts manifest.declaredEventTypes
|
||||
cats = jsonArrayTexts manifest.declaredAnnotationCategories
|
||||
scopes = jsonArrayTexts manifest.declaredPolicyScopes
|
||||
|
||||
conflicts <- fmap concat $ sequence
|
||||
[ concat <$> mapM (checkConflict "widget_type_registry" hub.id) wTypes
|
||||
, concat <$> mapM (checkConflict "event_type_registry" hub.id) eTypes
|
||||
, concat <$> mapM (checkConflict "annotation_category_registry" hub.id) cats
|
||||
, concat <$> mapM (checkConflict "policy_scope_registry" hub.id) scopes
|
||||
]
|
||||
unless (null conflicts) do
|
||||
respondWithStatus 422 $ object
|
||||
[ "error" .= ("Manifest activation blocked by type conflicts" :: Text)
|
||||
, "code" .= ("manifest_type_conflict" :: Text)
|
||||
, "conflicts" .= conflicts
|
||||
]
|
||||
|
||||
mapM_ (upsertType "widget_type_registry" hub.id) wTypes
|
||||
mapM_ (upsertType "event_type_registry" hub.id) eTypes
|
||||
mapM_ (upsertType "annotation_category_registry" hub.id) cats
|
||||
mapM_ (upsertType "policy_scope_registry" hub.id) scopes
|
||||
now <- getCurrentTime
|
||||
manifest <- manifest
|
||||
|> set #status "active"
|
||||
|> set #activatedAt (Just now)
|
||||
|> updateRecord
|
||||
renderJson (manifestToJson manifest)
|
||||
|
||||
manifestToJson :: HubCapabilityManifest -> Value
|
||||
manifestToJson manifest = object
|
||||
[ "id" .= manifest.id
|
||||
, "hubId" .= manifest.hubId
|
||||
, "manifestVersion" .= manifest.manifestVersion
|
||||
, "declaredWidgetTypes" .= manifest.declaredWidgetTypes
|
||||
, "declaredEventTypes" .= manifest.declaredEventTypes
|
||||
, "declaredAnnotationCategories" .= manifest.declaredAnnotationCategories
|
||||
, "declaredPolicyScopes" .= manifest.declaredPolicyScopes
|
||||
, "capabilityDescription" .= manifest.capabilityDescription
|
||||
, "contact" .= manifest.contact
|
||||
, "status" .= manifest.status
|
||||
, "activatedAt" .= manifest.activatedAt
|
||||
, "createdAt" .= manifest.createdAt
|
||||
, "updatedAt" .= manifest.updatedAt
|
||||
]
|
||||
|
||||
textArrayFieldFromRequestOrEmpty :: (?context :: ControllerContext, ?request :: Request) => Text -> [Text]
|
||||
textArrayFieldFromRequestOrEmpty fieldName =
|
||||
fromMaybe [] (textArrayFieldFromRequest fieldName)
|
||||
|
||||
textArrayFieldFromRequest :: (?context :: ControllerContext, ?request :: Request) => Text -> Maybe [Text]
|
||||
textArrayFieldFromRequest fieldName =
|
||||
case getHeader "Content-Type" of
|
||||
Just contentType | "application/json" `BS.isPrefixOf` contentType ->
|
||||
textArrayFieldFromJsonBody fieldName requestBodyJSON
|
||||
_ ->
|
||||
let values = paramList @Text fieldName
|
||||
in if null values then Nothing else Just values
|
||||
|
||||
textArrayFieldFromJsonBody :: Text -> Value -> Maybe [Text]
|
||||
textArrayFieldFromJsonBody fieldName (Object body) =
|
||||
case KM.lookup (K.fromText fieldName) body of
|
||||
Just (Array values) -> Just (mapMaybe extractText (V.toList values))
|
||||
_ -> Nothing
|
||||
where
|
||||
extractText (String value) = Just value
|
||||
extractText _ = Nothing
|
||||
textArrayFieldFromJsonBody _ _ = Nothing
|
||||
|
||||
jsonArrayTexts :: Value -> [Text]
|
||||
jsonArrayTexts (Array values) = mapMaybe extractText (V.toList values)
|
||||
where
|
||||
extractText (String value) = Just value
|
||||
extractText _ = Nothing
|
||||
jsonArrayTexts _ = []
|
||||
|
||||
checkConflict ::
|
||||
(?modelContext :: ModelContext) =>
|
||||
Text -> Id Hub -> Text -> IO [Text]
|
||||
checkConflict tableName hubId name = do
|
||||
rows <- sqlQuery
|
||||
(fromString $ cs ("SELECT owner_hub_id FROM " <> tableName <> " WHERE name = ?"))
|
||||
(Only name)
|
||||
case rows of
|
||||
[] -> pure []
|
||||
[Only Nothing] -> pure []
|
||||
[Only (Just ownerId)] ->
|
||||
if ownerId == hubId
|
||||
then pure []
|
||||
else pure ["Type '" <> name <> "' in " <> tableName <> " is already owned by another hub"]
|
||||
_ -> pure []
|
||||
|
||||
upsertType ::
|
||||
(?modelContext :: ModelContext) =>
|
||||
Text -> Id Hub -> Text -> IO ()
|
||||
upsertType tableName hubId name =
|
||||
void $ sqlExec
|
||||
(fromString $ cs ("INSERT INTO " <> tableName <> " (name, label, owner_hub_id, status) "
|
||||
<> "VALUES (?, ?, ?, 'active') ON CONFLICT (name) DO NOTHING"))
|
||||
(name, name, hubId)
|
||||
|
||||
nonEmptyText :: Text -> Maybe Text
|
||||
nonEmptyText "" = Nothing
|
||||
nonEmptyText value = Just value
|
||||
Reference in New Issue
Block a user