generated from coulomb/repo-seed
tegwick
5c13de1b8f
All checks were successful
Build and Deploy / build-push-deploy (push) Successful in 3m6s
141 lines
4.8 KiB
Haskell
141 lines
4.8 KiB
Haskell
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" -> createApiHub
|
|
_ -> respondWithStatus 405 $ object ["error" .= ("Method not allowed" :: Text)]
|
|
|
|
action ApiV2ShowHubAction { hubId } = do
|
|
_consumer <- requireApiConsumer
|
|
hub <- fetch hubId
|
|
renderJson (hubToJson hub)
|
|
|
|
action ApiV2CreateHubAction = createApiHub
|
|
|
|
listHubs :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO ()
|
|
listHubs = do
|
|
(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
|
|
|
|
createApiHub :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO ()
|
|
createApiHub = do
|
|
_consumer <- requireApiConsumer
|
|
let slug = paramOrNothing @Text "slug"
|
|
name = paramOrNothing @Text "name"
|
|
domain = paramOrNothing @Text "domain"
|
|
kind = fromMaybe "domain" (nonEmptyText =<< paramOrNothing @Text "hubKind")
|
|
hubFamily = nonEmptyText =<< paramOrNothing @Text "hubFamily"
|
|
vsmFunction = nonEmptyText =<< paramOrNothing @Text "vsmFunction"
|
|
vsmSystem = nonEmptyText =<< paramOrNothing @Text "vsmSystem"
|
|
|
|
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
|
|
]
|
|
|
|
unless (validVsmMetadata hubFamily vsmFunction vsmSystem) do
|
|
respondWithStatus 422 $ object
|
|
[ "error" .= ("Invalid VSM hub metadata" :: Text)
|
|
, "code" .= ("invalid_vsm_metadata" :: Text)
|
|
, "hint" .= ("Use no VSM fields, or set hubFamily=vsm with vsmFunction and vsmSystem." :: Text)
|
|
, "validVsmSystems" .= validVsmSystems
|
|
]
|
|
|
|
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
|
|
|> set #hubFamily hubFamily
|
|
|> set #vsmFunction vsmFunction
|
|
|> set #vsmSystem vsmSystem
|
|
|> 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
|
|
, "hubFamily" .= hub.hubFamily
|
|
, "vsmFunction" .= hub.vsmFunction
|
|
, "vsmSystem" .= hub.vsmSystem
|
|
, "createdAt" .= hub.createdAt
|
|
]
|
|
|
|
validCreateHubKinds :: [Text]
|
|
validCreateHubKinds = ["domain", "shared"]
|
|
|
|
validCreateHubKind :: Text -> Bool
|
|
validCreateHubKind kind = kind `elem` validCreateHubKinds
|
|
|
|
validVsmSystems :: [Text]
|
|
validVsmSystems = ["1", "2", "3", "3*", "4", "5", "environment"]
|
|
|
|
validVsmSystem :: Text -> Bool
|
|
validVsmSystem systemName = systemName `elem` validVsmSystems
|
|
|
|
validVsmMetadata :: Maybe Text -> Maybe Text -> Maybe Text -> Bool
|
|
validVsmMetadata Nothing Nothing Nothing = True
|
|
validVsmMetadata (Just "vsm") (Just functionName) (Just systemName) =
|
|
functionName /= "" && validVsmSystem systemName
|
|
validVsmMetadata _ _ _ = False
|
|
|
|
missingRequiredFields :: [(Text, Maybe Text)] -> [Text]
|
|
missingRequiredFields fields =
|
|
[ name | (name, value) <- fields, maybe True (== "") value ]
|
|
|
|
nonEmptyText :: Text -> Maybe Text
|
|
nonEmptyText "" = Nothing
|
|
nonEmptyText value = Just value
|