Microservices with too many types

Halp.hs

{-# LANGUAGE BlockArguments        #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}
module Halp where

import Data.Kind (Constraint, Type)
import GHC.TypeLits (ErrorMessage (..), TypeError)

import IDL (yamlToApp)

data Variant (xs :: [Type]) where
  Here  ::         x  -> Variant (x ': xs)
  There :: Variant xs -> Variant (y ': xs)

type Route (f :: Type -> Type) (input :: Type) (outputs :: [Type])
  = input -> f [Variant outputs]

type Route_ = ( Type, [Type] )

type (input :: Type) --> (output :: [Type])
  = '(input, output)

data Service (f :: Type -> Type) (routes :: [ (Type, [Type]) ]) where
  SNil :: Service f '[]
  (:+) :: Route f i o -> Service f xs -> Service f ( '(i, o) ': xs)

data EchoRequest
  = EchoRequest
      { text       :: String
      , enthusiasm :: Bool
      }

newtype EchoResponse
  = EchoResponse
      { text :: String
      }

route :: Route IO EchoRequest '[EchoResponse]
route (EchoRequest text' enthusiasm') = do
  putStrLn "RECEIVED REQUEST"

  pure if enthusiasm'
    then [ Here $ EchoResponse (text' <> "!") ]
    else [ Here $ EchoResponse  text'         ]

echo :: Service IO '[ '(EchoRequest, '[EchoResponse]) ]
echo = route :+ SNil

data HListF (f :: k -> Type) (xs :: [k]) where
  HNilF :: HListF f '[]
  HCons :: f x -> HListF f xs -> HListF f (x ': xs)

type App (f :: Type -> Type) (routes :: [[ (Type, [Type]) ]])
  = HListF (Service f) routes

type family (xs :: [k]) ++ (ys :: [k]) :: [k] where
  '[     ]  ++ ys = ys
  (x ': xs) ++ ys = x ': (xs ++ ys)

type family Drop (x :: k) (xs :: [k]) :: [k] where
  Drop x (x ': xs) =      Drop x xs
  Drop x (y ': xs) = y ': Drop x xs
  Drop x '[     ]  = '[]

type family (xs :: [k]) \\ (ys :: [k]) :: [k] where
  xs \\ '[] = xs
  xs \\ (x ': ys) = Drop x xs \\ ys

type family AllHeard (routes :: [[ Route_ ]]) :: Constraint where
  AllHeard routes = Unheard (Published routes \\ Subscribed routes)

type family Unheard (events :: [Type]) :: Constraint where
  Unheard '[] = ()
  Unheard  xs = TypeError
    (     'Text "The following events are produced, but nothing cares: "
    ':<>: 'ShowType xs
    )

type family AllSaid (routes :: [[ Route_ ]]) :: Constraint where
  AllSaid routes = Unsaid (Subscribed routes \\ Published routes)

type family Unsaid (events :: [Type]) :: Constraint where
  Unsaid '[] = ()
  Unsaid  xs = TypeError
    (     'Text "No one is producing any of the following events: "
    ':<>: 'ShowType xs
    )

type family Published (app :: [[ Route_ ]]) :: [Type] where
  Published '[       ]  = '[]
  Published ( x ': xs ) = Published_ x ++ Published xs

type family Published_ (app :: [ Route_ ]) :: [Type] where
  Published_ '[             ]  = '[]
  Published_ ( '(_, x) ': xs ) = x ++ Published_ xs

type family Subscribed (app :: [[ Route_ ]]) :: [Type] where
  Subscribed '[       ]  = '[]
  Subscribed ( x ': xs ) = Subscribed_ x ++ Subscribed xs

type family Subscribed_ (app :: [ Route_ ]) :: [Type] where
  Subscribed_ '[             ]  = '[]
  Subscribed_ ( '(x, _) ': xs ) = x ': Subscribed_ xs

check
  :: (AllSaid routes, AllHeard routes)
  => App IO routes -> App IO routes

check = id

type x ~~> y
  = '(x, y)

example
  :: App IO
      '[ '[ Bool ~~> '[]
          ]
       ]

example = undefined

-- TYPE ERROR:
-- test = check example

data Client
data Input
data Output

example1 :: App IO $(yamlToApp "IDL.yaml")
example1 = undefined

IDL.yaml

-
  Client:
    - Input

-
  Input:
    - Client
    - Output

-
  Output:
    - Client

Talk.md

---

author: 'Tom Harding' title: 'Microdisservices' patat: incrementalLists: true theme: code: [onDullWhite] codeBlock: [onVividWhite] ...

Making Legal States Unrepresentable

Act I: Overtyping

What is a "route"?

• An event of some type is raised.

• Some handler listening for that event is called.

• The handler produces some number of new events.

type ExampleHandler
  = HelloRequest
  → [Either HelloResponse InternalServerError]

• Fancier?

type ExampleHandler
  = HelloRequest
  → [Either HelloResponse (Either ValidationError InternalServerError)]

• This does not scale.

tom :: Obstruction → Abstraction

• We want any number of return types.

• Generate nested Either with TemplateHaskell?

• Let's use a GADT to generalise Either instead:

data Variant (xs :: [Type]) where
  Here  ::         x  -> Variant (x ': xs)
  There :: Variant xs -> Variant (y ': xs)

• Kind of a "pointer" in a list.

eg :: [ Variant '[String, Int, Bool] ]
eg
  = [ Here "hello"
    , There (Here 3)
    , There (There (Here True))
    ]

What is a "route"?

• An event of some type is raised.

• Some handler listening for that event is called.

• The handler produces some number of new events.

type Route (input :: Type) (outputs :: [Type])
  = input -> [Variant outputs]

• ... with effects

type Route (f :: Type -> Type) (input :: Type) (outputs :: [Type])
  = input -> f [Variant outputs]

• We have an event handler!

What is a "service"?

• A set of routes. That's... it.

type Service (f :: Type -> Type) (input :: Type) (outputs :: [Type])
  = [ Route f input outputs ]

• We need to be a bit cleverer.

data Service (f :: Type -> Type) (routes :: [ (Type, [Type]) ]) where
  SNil :: Service f '[]
  (:+) :: Route f i o -> Service f xs -> Service f ( '(i, o) ': xs)

• A service is a set of routes, indexed by a description of its router.

• Services can only return events that they say they'll return!

• We can define different semantics for how to handle overlaps (e.g. differently-indexed - or versioned - copies of the same event).

Our first service

data EchoRequest
  = EchoRequest
      { text       :: String
      , enthusiasm :: Bool
      }

newtype EchoResponse
  = EchoResponse
      { text :: String
      }

route :: Route IO EchoRequest '[EchoResponse]
route (EchoRequest text enthusiasm) = do
  putStrLn "RECEIVED REQUEST"

  pure if enthusiasm
    then [ Here $ EchoResponse (text <> "!") ]
    else [ Here $ EchoResponse  text         ]

echo :: Service IO '[ '(EchoRequest, '[EchoResponse]) ]
echo = route :+ SNil

🎓 Bonuses all round 👑

Orchestration?

• A microservice-architected app is just a list of microservices.

• ... but the elements of our lists have different types...

• An HList! Act surprised.

data HListF (f :: k -> Type) (xs :: [k]) where
  HNilF :: HListF f '[]
  (:++) :: f x -> HListF f xs -> HListF f (x ': xs)

• (Note the f and the k).

type App (f :: Type -> Type) (routes :: [[ (Type, [Type]) ]])
  = HListF (Service f) routes

• 🎺 Haskell all the things 🎺

... The Bad

Service topology

• We have the description in the types!

• We can write functions on this information!

• "What events are being produced in this app?"

type family (xs :: [k]) ++ (ys :: [k]) :: [k] where
  '[     ]  ++ ys = ys
  (x ': xs) ++ ys = x ': (xs ++ ys)

type family Published (app :: [[ Route_ ]]) :: [Type] where
  Published '[       ]  = '[]
  Published ( x ': xs ) = Published_ x ++ Published xs

type family Published_ (app :: [ Route_ ]) :: [Type] where
  Published_ '[             ]  = '[]
  Published_ ( '(_, x) ': xs ) = x ++ Published_ xs

• Small rant about UnsaturatedTypeFamilies not existing yet.

Service topology

• "What events are being consumed in this app?"

type family Subscribed (app :: [[ Route_ ]]) :: [Type] where
  Subscribed '[       ]  = '[]
  Subscribed ( x ': xs ) = Subscribed_ x ++ Subscribed xs

type family Subscribed_ (app :: [ Route_ ]) :: [Type] where
  Subscribed_ '[             ]  = '[]
  Subscribed_ ( '(x, _) ': xs ) = x ': Subscribed_ xs

• We can use Published_ and Subscribed_ to interrogate individual services.

• This isn't just for curiosity's sake - we can make guarantees!

• Let's write some other useful combinators at the type level...

Topology tools

• Drop an element from a type-level list.

type family Drop (x :: k) (xs :: [k]) :: [k] where
  Drop x (x ': xs) =      Drop x xs
  Drop x (y ': xs) = y ': Drop x xs
  Drop x '[     ]  = '[]

• Difference of two type-level lists.

type family (xs :: [k]) \\ (ys :: [k]) :: [k] where
  xs \\ '[] = xs
  xs \\ (x ': ys) = Drop x xs \\ ys

• So...

Ta-da!

• "What are we ignoring?"

type family AllHeard (routes :: [[ Route_ ]]) :: Constraint where
  AllHeard routes = Unheard (Published routes \\ Subscribed routes)

type family Unheard (events :: [Type]) :: Constraint where
  Unheard '[] = ()
  Unheard  xs = TypeError
    (     'Text "The following events are produced, but nothing cares: "
    ':<>: 'ShowType xs
    )

• We can detect "forgotten events" at compile time.

Two-da!

• "What are we waiting for?"

type family AllSaid (routes :: [[ Route_ ]]) :: Constraint where
  AllSaid routes = Unsaid (Subscribed routes \\ Published routes)

type family Unsaid (events :: [Type]) :: Constraint where
  Unsaid '[] = ()
  Unsaid  xs = TypeError
    (     'Text "No one is producing any of the following events: "
    ':<>: 'ShowType xs
    )

• We can detect "dead routes".

• Drum roll...

check :: (AllSaid rs, AllHeard rs) => App IO rs -> App IO rs
check = id

IDLs

What is an IDL?

• Describe data structures in a language-agnostic way.

• ... ish.

• We need types that are generated from external files.

• Maybe YAML because we don't like ourselves.

• Turning IO to syntax...

• You guessed it.

braceYourself :: App IO $(yamlToApp "IDL.yaml")

Why?!

• Surprisingly straightforward.

type Spec = [ Map String [ String ] ]

yamlToApp :: String -> Q Type
yamlToApp path
  = decodeFileThrow @_ @Spec path
      >>= pure . typeLevelList toService

typeLevelList :: (a -> Type) -> [a] -> Type
typeLevelList f
  = foldr (AppT . AppT PromotedConsT . f) PromotedNilT

toService :: Map String [ String ] -> Type
toService = typeLevelList (uncurry toRoute) . assocs
  where
    toRoute :: String -> [String] -> Type
    toRoute input
      = InfixT (ConT (mkName input)) (mkName "~~>")
      . typeLevelList (ConT . mkName)

Things not covered

• Static analysis (Selective, anyone?)

• Deployment orchestration

• Detecting infinite propagation

• Visualisation tools

Home time!