PureScript/Haskell bridge

0README.md

PureScript/Haskell bridge

This gist demonstrates a type-safe bridge between Haskell and PureScript in which you write a config/schema, config/rpc file (kinda like yesod's config/routes) and some template Haskell will output a .hs and .purs file via the templates/Schema.hs/templates/Schema.purs.

This also demonstrates migrations between schemas on a per-type basis. Similar to e.g. acid-state, when a type changes, we create a new type that is a copy of the old plus/minus our change and a version bump. Any types using the new type will define a migration from the old to the new. This way, old clients can talk to new servers. Additionally, older schema JSON saved in the database/redis can be read by newer servers.

Old types are marked as deprecated, which helps the developer to avoid using those old types in the codebase.

Separately, I use GenUnchecked from the genvalidity package to encode/decode from/to Haskell/PureScript with randomly generated inputs.

config-rpc

LoadDocument:
  input: DocumentId
  output: OutputDocument
RefreshDocument:
  input: RefreshDocument
  output: OutputDocument

config-schema

-- Samples from my config/schema
-- This file is valid Haskell and PureScript.

-- The version class makes it easy to work with explicit versions.
class Version v where
  versionNumber :: v -> Int
  versionRefl :: v

-- Each version type expects and writes as JSON with the number 1, 2, etc. 
-- This lets you write a JSON parser that backtracks across
-- different versions until it gets the right version. Aeson's
-- default encoding method doesn't let you distinguish reliably different
-- versions of types.
data Version1 = Version1
data Version2 = Version2

-- [...]

data InputCell1 = InputCell1
  { uuid :: UUID
  , name :: Text
  , code :: Text
  , order :: Int
  , version :: Version1
  }
  
data Row = Row
 { source :: OriginalSource
 , fields :: Vector Field2
 }

data Field2 = Field2
  { version :: Version2
  , key :: Text
  , value :: Tree2
  }
  
...
  
--------------------------------------------------------------------------------
-- Deprecated

-- [..]

{-# DEPRECATED Tree1 "Use Tree2" #-}
data Tree1
  = ArrayTree Version1 (Vector Tree1)
  | RecordTree Version1 (Vector Field1)
  | MiscTree Version1 Text

{-# DEPRECATED Field1 "Use Field2" #-}
data Field1 = Field1
  { version :: Version1
  , key :: Text
  , value :: Tree1
  }
  
...

templates-Rpc.hs

...

postAppRpcR :: Text -> Handler TypedContent
postAppRpcR name = selectRep (provideRep (rpcHandler name))

$calls

templates-Rpc.purs

...

$calls

...

rpcCall
  :: forall m input output i o
  .  MonadAff m
  => GenericEncode i
  => GenericDecode o
  => Generic input i
  => Generic output o
  => Show output
  => String
  -> input
  -> m (Either String output)
  
  ...

templates-Schema.hs

newtype UUID = UUID Text
 deriving (Eq, Ord, FromJSON, ToJSON, Show)

$types

...

deriving instance Generic InputDocument
deriving instance Show InputDocument
instance ToJSON InputDocument
instance FromJSON InputDocument

-- Implement explicit migrations from older versions into newer versions.
-- This is used by both the client and the server.
--
-- There are more complicated multi-version migrations, but this example
-- is fine.

deriving instance Generic InputDocument1
deriving instance Show InputDocument1
instance ToJSON InputDocument1
instance FromJSON InputDocument1 where
  parseJSON =
    withObject
      "InputDocument1"
      (\o -> do
         cells <- o .: "cells" <|> fmap migrateV1 (o .: "cells")
         pure InputDocument1 {cells})
    where
      migrateV1 :: Vector InputCell -> Vector InputCell1
      migrateV1 =
        V.imap
          (\order InputCell {..} ->
             InputCell1 {version = versionRefl, order, ..})
             
...

parseVersion :: forall v. Version v => Value -> Parser v
parseVersion j = do
  i <- parseJSON j
  if i == versionNumber (versionRefl :: v)
    then pure (versionRefl :: v)
    else fail
           ("Version mismatch, expected: " <> show (versionNumber (versionRefl :: v)) <>
            ", but got: " <>
            show i)

versionToJSON :: forall v. Version v => v -> Value
versionToJSON v = toJSON (versionNumber v)

--------------------------------------------------------------------------------
-- Versions

deriving instance Show Version1
instance Version Version1 where versionNumber _ = 1; versionRefl = Version1
instance FromJSON Version1 where parseJSON = parseVersion
instance ToJSON Version1 where toJSON = versionToJSON

deriving instance Show Version2
instance Version Version2 where versionNumber _ = 2; versionRefl = Version2
instance FromJSON Version2 where parseJSON = parseVersion
instance ToJSON Version2 where toJSON = versionToJSON

templates-Schema.purs

...

type Vector a = Array a

type Text = String

$types

--------------------------------------------------------------------------------
-- Derivings

...

derive instance genericDocumentId :: Generic DocumentId _
instance showDocumentId :: Show DocumentId where show = genericShow
instance decodeDocumentId :: Decode DocumentId where decode = genericDecode opts
instance encodeDocumentId :: Encode DocumentId where encode = genericEncode opts

--------------------------------------------------------------------------------
-- RPC call

rpcCall
  :: forall m input output i o
  .  MonadAff m
  => GenericEncode i
  => GenericDecode o
  => Generic input i
  => Generic output o
  => Show output
  => String
  -> input
  -> m (Either String output)
rpcCall endpoint0 input = ...

--------------------------------------------------------------------------------
-- Version infra

parseVersion :: forall v. Version v => Foreign -> F v
parseVersion j = do
  i <- decode j
  if i == versionNumber (versionRefl :: v)
    then pure (versionRefl :: v)
    else fail
           (TypeMismatch
              ("Version" <> show (versionNumber (versionRefl :: v)))
              ("Version" <> show i))

versionToJSON :: forall v. Version v => v -> Foreign
versionToJSON v = encode (versionNumber v)

--------------------------------------------------------------------------------
-- Versions

instance versionVersion1 :: Version Version1 where
  versionNumber _ = 1
  versionRefl = Version1
derive instance genericVersion1 :: Generic Version1 _
instance showVersion1 :: Show Version1 where show = genericShow
instance decodeVersion1 :: Decode Version1 where decode = parseVersion
instance encodeVersion1 :: Encode Version1 where encode = versionToJSON

instance versionVersion2 :: Version Version2 where
  versionNumber _ = 2
  versionRefl = Version2
derive instance genericVersion2 :: Generic Version2 _
instance showVersion2 :: Show Version2 where show = genericShow
instance decodeVersion2 :: Decode Version2 where decode = parseVersion
instance encodeVersion2 :: Encode Version2 where encode = versionToJSON