Skip to content

Instantly share code, notes, and snippets.

@i-am-tom
Created March 15, 2019 18:42
Show Gist options
  • Save i-am-tom/20bc844acba06c7be83537c0df084455 to your computer and use it in GitHub Desktop.
Save i-am-tom/20bc844acba06c7be83537c0df084455 to your computer and use it in GitHub Desktop.
Microservices with too many types
{-# 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
-
Client:
- Input
-
Input:
- Client
- Output
-
Output:
- Client

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!

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment