keiro-dsl-0.6.0.0: src/Keiro/Dsl/Skeleton.hs
-- | Starter @.keiro@ skeletons for the @new \<kind\>@ subcommand. Each skeleton
-- is a minimal, __valid__ spec for one node kind: it parses and passes
-- @validateSpec@ with zero error diagnostics (a test enumerates them), so the
-- skeletons double as living, guaranteed-valid notation examples.
--
-- Kinds whose validator couples to other nodes (a @publisher@ needs an @emit@; an
-- @emit@/@intake@ needs a @contract@; a @dispatch@ needs a @workqueue@; an
-- @operation@ references a @workflow@) ship the whole coupled mini-spec, so the
-- skeleton is self-contained and checks clean on its own.
module Keiro.Dsl.Skeleton
( skeletonFor,
skeletonKinds,
)
where
import Data.Text (Text)
import Data.Text qualified as T
-- | The valid @new \<kind\>@ arguments, in help/listing order.
skeletonKinds :: [Text]
skeletonKinds =
[ "aggregate",
"process",
"router",
"contract",
"intake",
"emit",
"publisher",
"workqueue",
"dispatch",
"workflow",
"operation"
]
-- | The minimal valid spec text for a node kind, or a 'Left' error naming the
-- valid kinds when the argument is unrecognised.
skeletonFor :: Text -> Either Text Text
skeletonFor kind = case kind of
"aggregate" -> Right (versioned aggregateSkeleton)
"process" -> Right (versioned processSkeleton)
"router" -> Right (versioned routerSkeleton)
"contract" -> Right (versioned contractSkeleton)
"intake" -> Right (versioned intakeSkeleton)
"emit" -> Right (versioned emitSkeleton)
"publisher" -> Right (versioned emitSkeleton)
"workqueue" -> Right (versioned workqueueSkeleton)
"dispatch" -> Right (versioned workqueueSkeleton)
"workflow" -> Right (versioned workflowSkeleton)
"operation" -> Right (versioned workflowSkeleton)
other ->
Left $
"unknown kind '" <> other <> "'. Valid kinds: " <> T.intercalate ", " skeletonKinds
where
versioned source = "language keiro-dsl 1\n" <> source
aggregateSkeleton :: Text
aggregateSkeleton =
T.unlines
[ "context my-service",
"",
"id ThingId prefix=thing",
"",
"aggregate Thing",
" regs",
" thingId ThingId = placeholder",
" state ThingVertex = Pending",
" states Pending Done!",
"",
" command DoThing { thingId attempt:Int }",
" event ThingCompleted { thingId attempt:Int }",
"",
" Pending -- DoThing -->",
" write state := Done",
" emit ThingCompleted",
" goto Done",
"",
" wire kind=ctorName fields=camelCase schemaVersion=1"
]
processSkeleton :: Text
processSkeleton =
T.unlines
[ "context my-service",
"",
"id HospitalId prefix=hosp",
"id CommandId prefix=cmd",
"",
"process HospitalSurge",
" name \"hospital-surge\"",
" input SurgeInput { hospitalId availableIcuBeds:Int redDemand:Int observedAt:Time }",
" correlate input.hospitalId via idText",
" saga Surge category \"hospitalSurge\"",
" target Hospital",
" projections [ ]",
"",
" on SurgeInput",
" advance NoteSurgeThreshold { hospitalId availableIcuBeds redDemand timerId=timer.id }",
" dispatch Hospital@input.hospitalId ActivateSurge { hospitalId }",
" on-appended AckOk ; on-duplicate AckOk ; on-failed Retry",
" schedule surgeFollowUp",
"",
" dispatch-id strategy=uuidv5 from=(name, correlationId, sourceEventId, emitIndex)",
" rejected => halt",
" poison => halt",
"",
" timer surgeFollowUp",
" id uuidv5 \"hospital-surge-timer:\" <> correlationId",
" fireAt input.observedAt + 5m",
" payload { kind=\"hospital-surge-follow-up\" hospitalId }",
" fire dispatch Surge@correlationId MarkSurgeTimerFired { hospitalId timerId }",
" fired-event-id uuidv5 \"hospital-surge-fired:\" <> correlationId",
" on-ok Fired ; on-reject Fired ; on-ambiguous Retry ; on-error Retry ; not-mine Retry",
" decode unknown-status => Cancelled",
" max-attempts 5 dead-letter \"surge timer exceeded ceiling\"",
"",
"aggregate Surge",
" regs",
" states Idle Fired!",
"",
" command NoteSurgeThreshold { hospitalId availableIcuBeds:Int redDemand:Int timerId }",
" command MarkSurgeTimerFired { hospitalId timerId }",
" event SurgeThresholdNoted = fields(NoteSurgeThreshold)",
" event SurgeTimerMarked = fields(MarkSurgeTimerFired)",
" Idle -- NoteSurgeThreshold --> emit SurgeThresholdNoted ; goto Idle",
" Idle -- MarkSurgeTimerFired --> emit SurgeTimerMarked ; goto Fired",
"",
"aggregate Hospital",
" regs",
" states Operational Surging!",
"",
" command ActivateSurge { hospitalId }",
" event SurgeActivated = fields(ActivateSurge)",
" Operational -- ActivateSurge --> emit SurgeActivated ; goto Surging"
]
routerSkeleton :: Text
routerSkeleton =
T.unlines
[ "context my-service",
"",
"router PagingRouter",
" name \"paging-router\"",
" input IncidentRaised { incidentId service }",
" key input.incidentId via idText",
" resolve stable via hole row { responderId }",
" target Page",
" projections [ ]",
" dispatch-each SendPage { incidentId=input.incidentId responderId=resolved.responderId }",
" on-appended AckOk ; on-duplicate AckOk ; on-failed Retry",
" dispatch-id strategy=uuidv5 from=(name, key, sourceEventId, targetStreamName, occurrence)",
" rejected => halt",
" poison => halt",
"",
"aggregate Page",
" regs",
" states Pending Delivered!",
"",
" command SendPage { incidentId responderId }",
" event PageSent = fields(SendPage)",
"",
" Pending -- SendPage --> emit PageSent ; goto Delivered"
]
contractSkeleton :: Text
contractSkeleton =
T.unlines
[ "context my-service",
"",
"contract myContract {",
" schemaVersion 1",
" discriminator messageType",
"",
" topic events \"my-service.events\"",
"",
" event ThingHappened on events {",
" thingId: typeid \"thing\"",
" detail: text",
" }",
"}"
]
intakeSkeleton :: Text
intakeSkeleton =
T.unlines
[ "context my-service",
"",
"contract myContract {",
" schemaVersion 1",
" discriminator messageType",
" topic events \"my-service.events\"",
" event ThingHappened on events {",
" thingId: typeid \"thing\"",
" }",
"}",
"",
"intake thingInbox {",
" contract myContract",
" topic events",
" accept ThingHappened",
"",
" bind messageId from header \"keiro-message-id\" required cross-check body",
"",
" dedupe key messageId policy PreferIntegrationMessageId",
"",
" decode {",
" envelope strict-required lenient-optional",
" body strict schemaVersion == 1",
" }",
"",
" disposition {",
" processed => ackOk",
" duplicate => ackOk",
" inProgress => retry 5s",
" previouslyFailed => deadLetter \"previous inbox failure\"",
" decodeFailed => deadLetter",
" dedupeFailed => deadLetter",
" storeFailed => retry 5s",
" }",
"}"
]
emitSkeleton :: Text
emitSkeleton =
T.unlines
[ "context my-service",
"",
"contract myContract {",
" schemaVersion 1",
" discriminator messageType",
" topic events \"my-service.events\"",
" event ThingAccepted on events {",
" thingId: typeid \"thing\"",
" }",
"}",
"",
"emit thingResponse {",
" contract myContract",
" topic events",
" source \"my-service\"",
" key thingId",
" map status {",
" \"accepted\" => ThingAccepted",
" _ => skip",
" }",
" messageId derive \"msg\" hole",
" idempotencyKey derive hole",
"}",
"",
"publisher thingPublisher {",
" emit thingResponse",
" ordering PerKeyHeadOfLine",
" maxAttempts 10",
" backoff constant 2s",
" outboxId stable from messageId",
"}"
]
workqueueSkeleton :: Text
workqueueSkeleton =
T.unlines
[ "context my-service",
"",
"readmodel accepted_transfer_needs {",
" table = \"accepted_transfer_needs\"",
" schema = \"my_service\"",
" columns {",
" reservation_id text required",
" hospital_id text required",
" }",
" version = 1",
" shape = \"fnv1a:fec517dae7760b8a\"",
" consistency = Eventual",
" feed = subscription",
"}",
"",
"readmodel transfer_decisions {",
" table = \"transfer_decisions\"",
" schema = \"my_service\"",
" columns {",
" reservation_id text required",
" }",
" version = 1",
" shape = \"fnv1a:d44d218822582783\"",
" consistency = Eventual",
" feed = subscription",
"}",
"",
"workqueue reservation_work {",
" queue logical = \"my_service.reservation_work\"",
" derive physical = \"my_service_reservation_work\"",
" dlq = \"my_service_reservation_work_dlq\"",
" table = \"pgmq.q_my_service_reservation_work\"",
"",
" payload ReservationWorkItem {",
" reservationId -> \"reservation_id\" text required",
" hospitalId -> \"hospital_id\" text required",
" }",
"",
" retry maxRetries = 3 delay = 5s dlq = on",
"",
" disposition {",
" storeFailure -> retry 5s",
" commandRejected -> deadLetter",
" decodeFailure -> deadLetter",
" onCodecReject -> deadLetter",
" }",
"}",
"",
"dispatch reservation_work_dispatch {",
" source readModel = accepted_transfer_needs key = reservationId",
" fanout body = resolveTransferCandidates",
" dedup key = reservationId",
" seenIn readModel = transfer_decisions field = reservation_id",
" seenIn queue = reservation_work field = reservation_id",
" enqueue to = reservation_work",
"}"
]
workflowSkeleton :: Text
workflowSkeleton =
T.unlines
[ "context my-service",
"",
"workflow HospitalTransferReservation",
" name \"hospital-transfer-reservation\"",
" in ReservationWorkflowInput { reservationId:Id hospitalId:Id }",
" out ReservationWorkflowSummary",
" id from input.reservationId via idText",
" body",
" step create-transfer-hold -> ReservationHold",
" await reservation-confirmation -> ReservationConfirmation",
" step summarize-reservation -> ReservationWorkflowSummary",
"",
"operation SignalReservationConfirmation",
" signal reservation-confirmation of HospitalTransferReservation",
" key from reservationId via reservationWorkflowId",
" value ReservationConfirmation",
"",
"operation RunReservationWorkflow",
" run HospitalTransferReservation",
" input ReservationWorkflowInput",
" outcome -> ReservationWorkflowRun"
]