The tandem harness

Updated October 4, 2026· Development

Sean Dinwiddie

A harness is the deterministic program around a model: the loop, the tools, the permissions and the context it works in. In tandem, the two run side by side on every request, and each does what it does best. The model proposes, and typed code decides what is allowed, what goes out and what changes.

This lesson builds one for an invented salon’s booking assistant, the way the Sean Dinwiddie’s Webmastery team builds the rest of its software: behavior named first, a pure core, effects at the edge. The code is Haskell with Servant, Hspec and QuickCheck, plus one TypeScript file tested with Vitest.

Every name, time, price and figure in it is invented, and no spec calls a model: a stand-in takes its seat.

What runs in tandem

Anthropic’s engineers call the Claude Agent SDK a general-purpose agent harness (Effective harnesses for long-running agents, November 2025), and the SDK’s overview says what that covers: the tools, the agent loop and the context management behind Claude Code. The loop from The agent loop and its tools is a harness too, a small one.

Here the pairing is a model beside a checker. The model proposes a time and the words of a reply, in one answer, and typed code decides what is on offer, what goes out and what gets held.

Research has a name for this pairing. Kambhampati and colleagues argue that a language model can’t plan or verify its own plans by itself, and pair it with external, model-based verifiers that check what it generates, in what they call LLM-Modulo frameworks (ICML 2024). In Automating a business process with a person in the loop, a person approved every change. Here, wherever the rule is known, code does the checking.

The behavior comes first, as a feature written in Gherkin, the way Given-When-Then (Gherkin) syntax in BDD teaches:

# the-tandem-harness/booking.feature
Feature: The salon's booking assistant answers inside what the calendar allows
  The model proposes a time and the reply, in one answer.
  The harness decides what is on offer, what goes out and what gets held.

  Scenario: Asking for a day with no openings
    Given only Tuesday at 3pm is open
    When the customer asks for Monday
    Then the reply offers Tuesday at 3pm
    And Tuesday at 3pm is held for the customer

  Scenario: A reply that invents a time is rejected and retried
    Given a first answer whose reply offers Wednesday at 10am, which the facts don't hold
    When the harness checks it
    Then it is rejected as an unsupported fact
    And the retry prompt holds the original prompt, the rejected answer and every reason

  Scenario: Running out of attempts
    Given a model whose every reply names a price nobody has set
    When the attempts run out
    Then the salon's own fallback line goes out instead of a reply
    And no hour is held

  Scenario: Another customer's booking stays out of the prompt
    Given Rosa is booked on Monday at 10am
    When the context is composed
    Then her name appears nowhere in the prompt

  Scenario: A model that never answers
    Given a turn limited to 200 ms
    And a model that never sends anything back
    When the limit passes
    Then the customer hears the salon's fallback line
    And no hour is held

The specs, in Spec.hs, take their names from the feature file, and one more spec fails if a scenario has no spec. The stand-in in the model’s seat is a pure function of the call: it takes the first option it’s offered, and writes its reply for that hour, in the shape the schema asks for.

-- the-tandem-harness/Spec.hs
-- | An answer as the schema shapes it: a choice and a reply, side by side.
answerJson :: Text -> Text -> Text
answerJson choice reply' = decodeUtf8 (BL.toStrict (encode (object ["choice" .= choice, "reply" .= reply'])))

-- | A stand-in for the model, written as a pure function of the call.
--   It takes the first option, and writes its first reply, and any correction, for that hour.
standIn :: (Text -> Text) -> (Text -> Text) -> Call -> Text
standIn first correction c = answerJson choice (write choice)
  where
    choice = head (grammar c)
    write = if attempt c == 1 then first else correction

good, invents, pricey :: Text -> Text
good hour = "Monday's full, sorry. " <> hour <> " is open. Want it? The price isn't on my sheet yet."
invents _ = "Monday's full, but Wednesday 10am is open. Want it?"
pricey hour = hour <> " is open, and a cut is $45."

careful, inventive, alwaysPricey :: Call -> Text
careful = standIn good good
inventive = standIn invents good
alwaysPricey = standIn pricey pricey

The runs on this page come from a UTF-8 terminal; under the POSIX locale, Hspec marks a pass [v] where they show ✔.

$ cabal test the-tandem-harness --test-show-details=direct --test-options='-m "Feature"' | grep -E '✔|✘|examples'
  Scenario: Asking for a day with no openings [✔]
  Scenario: A reply that invents a time is rejected and retried [✔]
  Scenario: Running out of attempts [✔]
  Scenario: Another customer's booking stays out of the prompt [✔]
  Scenario: A model that never answers [✔]
  has a spec for every scenario, and no spec without one [✔]
6 examples, 0 failures

Compose before the model speaks

Before the model sees anything, a pure compose picks what this request may use: the open hours, whether the day asked for has any, the price if the owner has set one, the hours on offer and the voice. The salon also knows who booked which hour. That never reaches the prompt, and the fourth scenario checks it.

The voice is a point in the salon’s design file, written in the format of Geometric reasoning as data. Point 010 is brief, casual and cautious, and the prompt carries those words, never the point. In Salon.hs:

-- the-tandem-harness/Salon.hs
-- | Pick the facts the request authorizes. No name, and nothing the model may not use, gets in.
compose :: Text -> Salon -> Request -> Context
compose voiceWords salon req =
  Context
    { voice = voiceWords
    , facts = askedDay : [label s <> " is open." | s <- open] <> priced
    , missing = ["price" | Nothing <- [price salon]]
    , options = map label (onOffer salon req)
    , question = says req
    }
  where
    open = openSlots salon
    askedDay
      | any ((== asked req) . day) open = tshow (asked req) <> " has openings."
      | otherwise = tshow (asked req) <> " has no openings."
    priced = ["A cut is " <> p <> "." | Just p <- [price salon]]

-- | The prompt the model sees, rendered from the composed context and nothing else.
writePrompt :: Context -> Text
writePrompt c =
  T.unlines $
    [ "You answer booking questions for a hair salon."
    , "Answer in a " <> voice c <> " voice, in at most " <> tshow replyLimit <> " characters."
    , "Choose one of the options, and name it in your reply."
    , "Facts:"
    ]
      <> bullets (facts c)
      <> (if null (missing c) then [] else "Not on the sheet:" : bullets (missing c))
      <> ["Options:"]
      <> bullets (options c)
      <> ["Customer: " <> question c]
  where
    bullets = map ("- " <>)

writePrompt is a pure function from a context to text, so a spec reads exactly what the model is sent. Every model call’s record keeps its prompt as sent, and the records section below prints one, byte for byte.

One offer list for the grammar and the checker

The options the model may choose from come from one function, onOffer: every open hour, the day asked for first. An hour someone else holds is never on it.

If no hour is open, the list is empty, and the turn ends without a single model call: an empty list makes a grammar no output can satisfy.

-- the-tandem-harness/Salon.hs
-- | The hours on offer: every open hour, the day asked for first.
--   The grammar and the checker both read this one list.
onOffer :: Salon -> Request -> [Slot]
onOffer salon req = sortOn ((/= asked req) . day) (openSlots salon)

That one function feeds two things. The grammar narrows what the model can write, and the checker decides what the harness accepts. compose calls onOffer for the grammar’s options and takeTurn calls it for the checker, on the same calendar and request, so they agree, and a property makes sure they stay that way.

The model answers in one call, and Claude’s structured outputs give that answer its shape: they constrain a response to a JSON Schema, where enum is supported, minLength and maxLength are not, and every object sets additionalProperties to false. The schema holds two fields, the choice, an enum of the options on offer, and the reply.

Module 5’s loop is TypeScript, so here is the grammar in TypeScript, built from the options the composed context carries:

// src/the-tandem-harness/grammar.ts
// The output schema the model's answer carries: one option from the offer list, and the reply.

export type AnswerSchema = {
  readonly type: "object";
  readonly properties: {
    readonly choice: { readonly type: "string"; readonly enum: readonly string[] };
    readonly reply: { readonly type: "string" };
  };
  readonly required: readonly ["choice", "reply"];
  readonly additionalProperties: false;
};

/** Built from the offer list the harness's checker reads, and from nothing else. */
export const grammarFor = (options: readonly string[]): AnswerSchema => {
  if (options.length === 0) throw new Error("an empty enum is a grammar no output can satisfy");
  if (new Set(options.map((o) => o.toLowerCase())).size !== options.length)
    throw new Error("options must differ by more than capitalization");
  return {
    type: "object",
    properties: { choice: { type: "string", enum: [...options] }, reply: { type: "string" } },
    required: ["choice", "reply"],
    additionalProperties: false,
  };
};

A week of five bookable hours has thirty-one calendars with something open, few enough to check every one. The last test reads the call the Haskell harness logged, so the grammar is built from the very options its prompt showed:

$ npx vitest run src/the-tandem-harness/grammar.test.ts --reporter=verbose | grep -E '✓|✗|Tests' | sed -E 's/ [0-9]+ms$//'
 ✓ src/the-tandem-harness/grammar.test.ts > the grammar for an answer > Given every calendar of a five-slot week, When its grammar is built, Then the enum is exactly its open slots
 ✓ src/the-tandem-harness/grammar.test.ts > the grammar for an answer > Given any calendar, When the schema is built, Then the choice and the reply are its only properties, both required
 ✓ src/the-tandem-harness/grammar.test.ts > the grammar for an answer > Given any calendar, When the schema is built, Then it closes the object and uses no length constraint
 ✓ src/the-tandem-harness/grammar.test.ts > the grammar for an answer > Given no open slot, or two that differ only in case, When a grammar is asked for, Then it refuses
 ✓ src/the-tandem-harness/grammar.test.ts > the grammar for an answer > Given the call the Haskell harness logged, When a grammar is built from its prompt's options, Then the logged choice is in the enum
      Tests  5 passed (5)

The reply has no length in the schema, since maxLength isn’t supported, so its limit is the checker’s job. The checker parses the choice into a Slot or refuses it, the habit Alexis King names Parse, don’t validate.

The checker also compares without regard to case, because the structured-outputs page warns that an enum value can come back differing only in capitalization. A choice off the list is a reason like any other, NotOnOffer:

-- the-tandem-harness/Harness.hs
-- | The model's answer: one object, a choice from the offer list and the reply.
data Answer = Answer Text Text

instance FromJSON Answer where
  parseJSON = withObject "answer" (\o -> Answer <$> o .: "choice" <*> o .: "reply")

-- | Read a choice against the offer list. Casing isn't guaranteed, so match without it.
pick :: [Slot] -> Text -> Either Reason Slot
pick offer choice = maybe (Left (NotOnOffer choice)) Right (find (same . label) offer)
  where
    same l = T.toLower l == T.toLower choice

QuickCheck holds the two together. Over random calendars, every option the grammar is built from passes the checker in any casing, and every hour not on offer fails it:

$ cabal test the-tandem-harness --test-show-details=direct --test-options='-m "one offer list"' | grep -E '✔|✘|OK|examples'
  every option the grammar is built from passes the checker, in any casing, and nothing else does [✔]
    +++ OK, passed 100 tests.
  every open hour is on offer, the day asked for first, and no hour someone else holds [✔]
    +++ OK, passed 100 tests.
  an empty offer list ends the turn without a model call [✔]
3 examples, 0 failures

The property earns its keep when the two drift apart. Point compose at the whole schedule instead of the offer list, so the grammar offers an hour someone else already holds, and the first calendar QuickCheck tries breaks it:

$ sed -i.bak 's/options = map label (onOffer salon req)/options = map label (schedule salon)/' the-tandem-harness/Salon.hs
$ cabal test the-tandem-harness --test-show-details=direct --test-options='-m "one offer list" --seed 7' 2>&1 | grep -E '✔|✘|Falsified|/=|examples'
  every option the grammar is built from passes the checker, in any casing, and nothing else does [✘]
  every open hour is on offer, the day asked for first, and no hour someone else holds [✔]
  an empty offer list ends the turn without a model call [✔]
       Falsified (after 1 test):
         Left (NotOnOffer "wEdNeSday 10am") /= Right "Wednesday 10am"
3 examples, 1 failure

Exactly as written, or not at all

Each turn runs in two lanes. The harness frames the work, the model does it, and both end at one contract:

The reply goes out exactly as written or not at all. Every way to fail is a constructor of one closed type, and checkAnswer reads the choice and the reply together and collects every reason that applies, not just the first.

mentions pulls out the claims a checker can test, and a day with a time beside it is one claim, an hour. So an hour the facts don’t hold is an unsupported fact, even when its day and its time each appear in them:

-- the-tandem-harness/Harness.hs
-- | Every way an answer can fail its check. The set is closed: a new way is a new constructor.
data Reason
  = WrongShape Text      -- not a choice and a reply, an empty reply, or one longer than the prompt allows
  | NotOnOffer Text      -- a choice the offer list doesn't hold
  | ChoiceNotNamed Text  -- the reply doesn't name the hour chosen
  | UnsupportedFact Text -- an hour, a day, a time or a price the facts don't hold
  | MissingNotNamed Text -- something the sheet doesn't hold, left unsaid
  deriving stock (Eq, Show)

-- | An answer that passed is the hour and the reply as written; a rejected one, every reason at once.
data Ruling = Passed Slot Text | Rejected (NonEmpty Reason)
  deriving stock (Eq, Show)

-- | A claim the checker can test. A day with a time beside it is one claim, an hour.
data Claim = At Text Text | OnDay Text | AtTime Text | Price Text
  deriving stock (Eq, Show)

-- | The claims in a text, lowercased. "Tuesday 3pm", "Tuesday at 3 pm" and "3pm on Tuesday" are one hour;
--   a day or a time with nothing beside it is a claim of its own; "$45" and "45 dollars" are a price.
mentions :: Text -> [Claim]
mentions = nub . claims . T.words . T.toLower . T.map (\c -> if isAlphaNum c || c == '$' then c else ' ')
  where
    claims ws = case ws of
      d : rest | isDay d, Just (t, rest') <- time (dropWhile (== "at") rest) -> At d t : claims rest'
      _ | Just (t, rest) <- time ws, d : rest' <- dropWhile (== "on") rest, isDay d -> At d t : claims rest'
      _ | Just (t, rest) <- time ws -> AtTime t : claims rest
      n : unit : rest | isNumber n, unit `elem` ["dollar", "dollars"] -> Price ("$" <> n) : claims rest
      w : rest -> [OnDay w | isDay w] <> [Price w | "$" `T.isPrefixOf` w] <> claims rest
      [] -> []
    time = \case
      n : m : rest | isNumber n, m `elem` ["am", "pm"] -> Just (n <> m, rest)
      w : rest | any (`T.isSuffixOf` w) ["am", "pm"], isNumber (T.dropEnd 2 w) -> Just (w, rest)
      _ -> Nothing
    isNumber w = not (T.null w) && T.all isDigit w
    isDay = (`elem` ["monday", "tuesday", "wednesday", "thursday", "friday", "saturday", "sunday"])

-- | Whether the facts hold a claim. An hour or a price must be one the facts name;
--   a day or a time alone, one that some fact names.
holds :: [Claim] -> Claim -> Bool
holds known = \case
  OnDay d -> d `elem` ([d' | At d' _ <- known] <> [d' | OnDay d' <- known])
  AtTime t -> t `elem` ([t' | At _ t' <- known] <> [t' | AtTime t' <- known])
  claim -> claim `elem` known

claimWords :: Claim -> Text
claimWords = \case
  At d t -> d <> " " <> t
  OnDay d -> d
  AtTime t -> t
  Price p -> p

-- | Every reason a reply can't go out with the choice it came with.
replyReasons :: Context -> Text -> Text -> [Reason]
replyReasons ctx choice text =
  [WrongShape "an empty reply" | T.null (T.strip text)]
    <> [WrongShape ("a reply over " <> tshow replyLimit <> " characters") | T.length text > replyLimit]
    <> [ChoiceNotNamed choice | not (all (`elem` claimed) (mentions choice))]
    <> [UnsupportedFact (claimWords c) | c <- claimed, not (holds known c)]
    <> [MissingNotNamed m | m <- missing ctx, not (T.toLower m `T.isInfixOf` T.toLower text)]
  where
    claimed = mentions text
    known = concatMap mentions (facts ctx)

-- | The answer read whole, the choice and the reply together:
--   the hour and the reply as written, or every reason they can't go out.
checkAnswer :: Context -> [Slot] -> Text -> Ruling
checkAnswer ctx offer raw = case eitherDecodeStrict (encodeUtf8 raw) of
  Left _ -> Rejected (pure (WrongShape "not a choice and a reply"))
  Right (Answer choice text) -> case (pick offer choice, nonEmpty (replyReasons ctx choice text)) of
    (Right slot, Nothing) -> Passed slot text
    (Right _, Just reasons) -> Rejected reasons
    (Left offList, reasons) -> Rejected (offList :| foldMap toList reasons)

A rejection gets a bounded retry of the same call. The retry prompt carries the original prompt, the answer that was rejected and every reason the checker gave, the move LLM-Modulo calls back-prompting: the critics’ critiques become the model’s next prompt. Here the rejected answer goes back with them.

-- the-tandem-harness/Harness.hs
-- | The original prompt, the answer that was rejected, and every reason the checker gave.
correctionPrompt :: Context -> Text -> NonEmpty Reason -> Text
correctionPrompt ctx rejected reasons =
  writePrompt ctx
    <> "Your last answer was not sent: "
    <> rejected
    <> "\nWhy: "
    <> T.intercalate "; " (map explain (toList reasons))
    <> ".\n"

Every attempt is recorded. When the attempts run out, three here, an invented figure, the salon’s own fallback line goes out instead of a reply. That is the third scenario.

A time limit on the turn

A customer waiting on a booking shouldn’t wait forever, so a turn has a time limit: 6,000 ms here, an invented figure. The pure core reads no clock.

The limit is enforced at the edge, in Api.hs, where timeout from base’s System.Timeout runs the whole turn and returns Nothing when no result comes within the limit, stopping the turn wherever it is, mid-call included:

-- the-tandem-harness/Api.hs
-- | One request. The whole turn runs under one time limit, and the turn writes nothing,
--   so a turn stopped at the limit leaves nothing to undo.
serveTurn :: Env -> Model IO -> TVar Salon -> TVar [[Record]] -> Request -> IO Outcome
serveTurn env model' salonVar logVar req = do
  salon <- readTVarIO salonVar
  ran <- timeout (limit env * 1000) (takeTurn env model' salon req)
  atomically $ case ran of
    Nothing -> keep [Refused (OutOfTime (limit env))] (Fallback (OutOfTime (limit env)))

Stopping a turn is safe because the turn writes nothing. The calendar changes only after the turn returns, in the handler, so a turn stopped at the limit leaves nothing to undo, and the customer hears the fallback line. The stopped turn’s own records go with it, so the log keeps one record for it, the refusal.

The fifth scenario is that case, with a 200 ms limit and a stand-in that never sends anything back.

Two more specs pin the edge from both sides. A model given five seconds of work is stopped inside one second, at the limit, and a model that answers inside the limit finishes its turn:

$ cabal test the-tandem-harness --test-show-details=direct --test-options='-m "a time limit"' | grep -E '✔|✘|examples'
  stops a model slower than the limit at the limit, not when the model answers [✔]
  leaves a model inside the limit to finish its turn [✔]
2 examples, 0 failures

A record at every stage

Each stage writes a record as the turn runs: compose, each model call, each check, the hold, and a read-back of what the calendar shows afterwards. A turn that fails closed records why. The records are plain data, never changed once written, so a test, a log or a later lesson can read them without the harness running.

An audit runs five checks over the records, each on its own: the pick was an option the prompt offered, a hold follows only an answer that passed, the hold is the pick, the hold was read back, and the calendar shows it. It runs them through a Validation, which keeps every failure, so every failed check is reported at once.

The lecture Monads in Functional Programming gives Validation the same shape: Either’s, but with no way to chain, so it never stops at the first failure (Validation: fail fast or accumulate?).

-- the-tandem-harness/Harness.hs
-- | Either's shape, but its Applicative collects every failure, and it has no Monad instance.
data Validation e a = Failure e | Success a
  deriving stock (Eq, Show, Functor)

instance Semigroup e => Applicative (Validation e) where
  pure = Success
  Failure a <*> Failure b = Failure (a <> b)
  Failure a <*> Success _ = Failure a
  Success _ <*> Failure b = Failure b
  Success f <*> Success x = Success (f x)

-- the-tandem-harness/Harness.hs
-- | One record per stage, plain data, written as the turn runs and never changed after.
data Record
  = Composed [Text]       -- compose: the options the prompt offered
  | Called Int Text Text  -- a model call: the attempt, the prompt sent, what came back
  | Checked Ruling        -- check: the choice and the reply, passed or rejected together
  | Held Text Slot        -- hold: the hour the harness asked the calendar for
  | ReadBack (Maybe Slot) -- read back: what the calendar shows afterwards
  | Refused Halt          -- fail closed: why the turn ended without a reply
  deriving stock (Eq, Show)

-- | Every check run on its own, and every failed one reported at once.
audit :: [Record] -> Validation [Text] ()
audit rs =
  sequenceA_
    [ verify "the pick is an option the prompt offered" (all ((`elem` offered) . label) picked)
    , verify "a hold follows only an answer that passed" (null held || lastPassed)
    , verify "the hold is the pick" (all (`elem` picked) held)
    , verify "the hold was read back" (length readBacks == length held)
    , verify "the calendar shows the hold" (and (zipWith (==) readBacks (map Just held)))
    ]
  where
    offered = concat [o | Composed o <- rs]
    picked = [s | Checked (Passed s _) <- rs]
    held = [s | Held _ s <- rs]
    lastPassed = case reverse [r | Checked r <- rs] of
      Passed {} : _ -> True
      _ -> False
    readBacks = [o | ReadBack o <- rs]
    verify finding ok = if ok then Success () else Failure [finding]

The pure turn ends at the hold, so its records alone fail the read-back check. The read-back comes from the handler below, in the same transaction that tries the hold, so every hold the handler tries is read back. A turn that falls back before a hold has nothing to read back.

$ cabal test the-tandem-harness --test-show-details=direct --test-options='-m "a record at every stage"' | grep -E '✔|✘|examples'
  reports a hold that was never read back [✔]
  passes once the calendar shows the hold [✔]
  reports a hold the calendar doesn't show, as when another request took the hour first [✔]
  reports every failed check at once [✔]
4 examples, 0 failures

The records have a second reader, training. Martin Zinkevich’s Rules of Machine Learning names one remedy for training-serving skew in Rule 29: save what serving used, and train on that log. So every model call’s record holds its prompt exactly as sent, and servedLog turns those records into JSON, one value per call with how the checker ruled, which the committed log holds a line each:

-- the-tandem-harness/Harness.hs
-- | Every model call as serving made it: the prompt exactly as sent, what came back, and how the checker ruled.
--   Training reads these lines, so it learns from the prompts serving really rendered.
servedLog :: [Record] -> [Value]
servedLog rs = zipWith line [(n, sent, got) | Called n sent got <- rs] [r | Checked r <- rs]
  where
    line (n, sent, got) r =
      object ["call" .= ("attempt " <> tshow n), "prompt" .= sent, "output" .= got, "ruling" .= ruled r]
    ruled = \case
      Passed {} -> "passed" :: Text
      Rejected _ -> "rejected"

Here is the first prompt in the committed log, for a salon with two open hours, at point 010 of its design:

$ head -1 the-tandem-harness/served.jsonl | jq -j .prompt
You answer booking questions for a hair salon.
Answer in a brief, casual, cautious voice, in at most 280 characters.
Choose one of the options, and name it in your reply.
Facts:
- Monday has no openings.
- Tuesday 3pm is open.
- Thursday 10am is open.
Not on the sheet:
- price
Options:
- Tuesday 3pm
- Thursday 10am
Customer: Can I get a cut Monday? What’s the price?

The curly apostrophe in the question is there on purpose: a log that mangles UTF-8 fails the byte comparison.

The specs hold the committed log to what a turn records, line for line. Geometric reasoning in model training builds its rows from these lines instead of rendering the prompts again:

$ cabal test the-tandem-harness --test-show-details=direct --test-options='-m "the served log"' | grep -E '✔|✘|examples'
  asks in the design's point, in words [✔]
  holds every prompt exactly as sent, with what came back and how it was ruled [✔]
  keeps the curly apostrophe the customer typed, byte for byte [✔]
3 examples, 0 failures

Measuring reasoning on the geometry reads records like these across the points of a design.

Fail closed

An outcome is an offer or a fallback. Every failure, from a turn out of time to an hour another request took first, goes through the one Fallback constructor. It has no field for a reply or a hold, so a fallback can’t carry one, and effects returns nothing for it:

-- the-tandem-harness/Harness.hs
data Halt
  = NothingToOffer
  | AnswersRejected (NonEmpty Reason)
  | OutOfTime Ms -- the turn ran past its limit
  | HoldTaken    -- another request took the hour before the hold landed
  deriving stock (Eq, Show)

-- | An offer carries the reply and the hour to hold.
--   Every failure goes through the one Fallback constructor, which has room for neither.
data Outcome
  = Offered {reply :: Text, for :: Text, hold :: Slot}
  | Fallback Halt
  deriving stock (Eq, Show)

data Turn = Turn {outcome :: Outcome, records :: [Record]}

-- | The salon's own line, written once, never generated. An internal failure is never sent.
fallback :: Text
fallback = "I can't book that here. Please call the salon and the front desk will sort it out."

-- | What the customer gets: the reply that passed, or the salon's own line.
toCustomer :: Outcome -> Text
toCustomer = \case
  v@Offered {} -> reply v
  Fallback _ -> fallback

effects :: Outcome -> [Effect]
effects = \case
  v@Offered {} -> [Hold (for v) (hold v)]
  Fallback _ -> []

Internal failures never reach the customer. On any failure the customer hears the salon’s own fallback line, and the failure itself stays in the records, the plain-data failure of the lecture Practical Applications of Functional Programming (Represent expected failure as plain data).

Any reply that went out traces back to what made it, through the turn’s records: the options the prompt offered, every model call with its prompt and what came back, each check, and the hold.

Here is the whole turn, as the specs run it. There is one kind of call, ask, made again with the reasons when an answer is rejected:

-- the-tandem-harness/Harness.hs
-- | One turn: compose, then ask for a choice and a reply in one answer, and check the two together.
--   A rejected answer goes back with its reasons, until one passes or the attempts run out.
takeTurn :: Monad m => Env -> Model m -> Salon -> Request -> m Turn
takeTurn env model' salon req
  | null offer = stop [Composed []] NothingToOffer
  | otherwise = ask 1 (writePrompt ctx) [Composed (options ctx)]
  where
    ctx = compose (voiceText env) salon req
    offer = onOffer salon req
    who = customer req
    stop rs failure = pure (Turn (Fallback failure) (reverse (Refused failure : rs)))

    ask n text rs = do
      got <- model' (Call n text (options ctx))
      let rs' = Called n text got : rs
      case checkAnswer ctx offer got of
        passed@(Passed slot reply') ->
          pure (Turn (Offered reply' who slot) (reverse (Held who slot : Checked passed : rs')))
        rejected@(Rejected reasons)
          | n < attempts env -> ask (n + 1) (correctionPrompt ctx got reasons) (Checked rejected : rs')
          | otherwise -> stop (Checked rejected : rs') (AnswersRejected reasons)

The Servant API stays as thin as the handlers in The API: Haskell Servant and Nile. One route takes a request and answers an outcome. The handler runs the turn under its time limit, the model call its only effect, and then applies the outcome’s effects.

Another request can take the hour while the model is writing. So, in one STM transaction, the handler applies the effects to the calendar as it stands now, reads the hold back from the result, and writes the calendar only if the hold is there:

-- the-tandem-harness/Api.hs
-- One route, and a handler that stays thin: the turn decides, the handler applies and reads back.
module Api (BookingAPI, app, serveTurn) where

import Control.Concurrent.STM
import Control.Monad.IO.Class (liftIO)
import Data.List (find)
import Harness
import Salon
import Servant
import System.Timeout (timeout)

type BookingAPI = "turn" :> ReqBody '[JSON] Request :> Post '[JSON] Outcome

app :: Env -> Model IO -> TVar Salon -> TVar [[Record]] -> Application
app env model' salonVar logVar = serve (Proxy :: Proxy BookingAPI) (liftIO . serveTurn env model' salonVar logVar)

-- | One request. The whole turn runs under one time limit, and the turn writes nothing,
--   so a turn stopped at the limit leaves nothing to undo.
serveTurn :: Env -> Model IO -> TVar Salon -> TVar [[Record]] -> Request -> IO Outcome
serveTurn env model' salonVar logVar req = do
  salon <- readTVarIO salonVar
  ran <- timeout (limit env * 1000) (takeTurn env model' salon req)
  atomically $ case ran of
    Nothing -> keep [Refused (OutOfTime (limit env))] (Fallback (OutOfTime (limit env)))
    Just done -> case outcome done of
      Fallback _ -> keep (records done) (outcome done)
      v@Offered {} -> do
        now <- readTVar salonVar
        let after = foldr applyEffect now (effects v)
            shown = snd <$> find ((== for v) . fst) (booked after)
        if shown == Just (hold v)
          then writeTVar salonVar after >> keep (records done <> [ReadBack shown]) v
          else keep (records done <> [ReadBack shown, Refused HoldTaken]) (Fallback HoldTaken)
  where
    keep rs v = modifyTVar' logVar (rs :) >> pure v

If the hour is gone, the handler writes nothing to the calendar. The customer hears the fallback, the records end with the read-back and the refusal, and the audit reports the failed check. hspec-wai calls the application directly, with the stand-in in the model’s seat; in the third spec, someone else books the hour mid-turn:

$ cabal test the-tandem-harness --test-show-details=direct --test-options='-m "POST /turn"' | grep -E '✔|✘|examples'
  holds the slot and reads the hold back [✔]
  answers the fallback for a failed turn, with no change to the calendar [✔]
  answers the fallback, and writes nothing, when another request takes the hour first [✔]
3 examples, 0 failures

The booking still has to cross the wire. Server and client in tandem carries a booking across it in two rounds, with no session kept on the server between them.