Skip to content

Instantly share code, notes, and snippets.

@chrisdone

chrisdone/0README.md Secret

Last active Oct 26, 2020
Embed
What would you like to do?
PureScript/Haskell bridge

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.

LoadDocument:
input: DocumentId
output: OutputDocument
RefreshDocument:
input: RefreshDocument
output: OutputDocument
-- 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
}
...
...
postAppRpcR :: Text -> Handler TypedContent
postAppRpcR name = selectRep (provideRep (rpcHandler name))
$calls
...
$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)
...
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
...
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment