generated from coulomb/repo-seed
tegwick
a2d0dddddd
Some checks failed
Build and Deploy / build-push-deploy (push) Failing after 8m21s
275 lines
13 KiB
Haskell
275 lines
13 KiB
Haskell
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.Text.Encoding as TE
|
|
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)
|
|
]
|
|
declaredWidgetTypes <- textArrayFieldFromRequestOrEmpty "declaredWidgetTypes"
|
|
declaredEventTypes <- textArrayFieldFromRequestOrEmpty "declaredEventTypes"
|
|
declaredAnnotationCategories <- textArrayFieldFromRequestOrEmpty "declaredAnnotationCategories"
|
|
declaredPolicyScopes <- textArrayFieldFromRequestOrEmpty "declaredPolicyScopes"
|
|
manifest <- newRecord @HubCapabilityManifest
|
|
|> set #hubId hubId
|
|
|> set #manifestVersion manifestVersion
|
|
|> set #declaredWidgetTypes (toJSON declaredWidgetTypes)
|
|
|> set #declaredEventTypes (toJSON declaredEventTypes)
|
|
|> set #declaredAnnotationCategories (toJSON declaredAnnotationCategories)
|
|
|> set #declaredPolicyScopes (toJSON 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)
|
|
]
|
|
|
|
maybeDeclaredWidgetTypes <- textArrayFieldFromRequest "declaredWidgetTypes"
|
|
maybeDeclaredEventTypes <- textArrayFieldFromRequest "declaredEventTypes"
|
|
maybeDeclaredAnnotationCategories <- textArrayFieldFromRequest "declaredAnnotationCategories"
|
|
maybeDeclaredPolicyScopes <- textArrayFieldFromRequest "declaredPolicyScopes"
|
|
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 maybeDeclaredWidgetTypes
|
|
declaredEventTypes = maybe manifest.declaredEventTypes toJSON maybeDeclaredEventTypes
|
|
declaredAnnotationCategories = maybe manifest.declaredAnnotationCategories toJSON maybeDeclaredAnnotationCategories
|
|
declaredPolicyScopes = maybe manifest.declaredPolicyScopes toJSON maybeDeclaredPolicyScopes
|
|
|
|
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 -> IO [Text]
|
|
textArrayFieldFromRequestOrEmpty fieldName =
|
|
fromMaybe [] <$> textArrayFieldFromRequest fieldName
|
|
|
|
textArrayFieldFromRequest :: (?context :: ControllerContext, ?request :: Request) => Text -> IO (Maybe [Text])
|
|
textArrayFieldFromRequest fieldName =
|
|
case getHeader "Content-Type" of
|
|
Just contentType | "application/json" `BS.isPrefixOf` contentType -> do
|
|
body <- requestBodyJSON
|
|
pure $ textArrayFieldFromJsonBody fieldName body
|
|
_ ->
|
|
let values = paramList @Text (TE.encodeUtf8 fieldName)
|
|
in pure $ 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
|