wireform-proto-0.1.0.0: python-interop/Main.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{- | wireform-proto ↔ Python google-protobuf interop test.
Run after installing google-protobuf in your Python environment:
pip install protobuf
cabal run wireform-proto:wireform-proto-python-interop
Skipped automatically when @python3@ is not in PATH or @google-protobuf@
is not installed.
What is tested:
1. Haskell encodes a message → Python decodes (google-protobuf) and
re-encodes → Haskell compares bytes. Verifies the wire format is
accepted by the official implementation.
2. Python encodes a message from a JSON field spec → Haskell decodes →
Haskell checks field values. Verifies Haskell can consume bytes
produced by the official implementation.
Both directions are exercised for: scalar fields, enum, nested
submessage, repeated, map, optional presence, and all numeric kinds.
-}
module Main where
import Control.Exception (SomeException, try)
import Data.Aeson ((.=))
import Data.Aeson qualified as A
import Data.Aeson.Types qualified as AT
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Base64 qualified as B64
import Data.ByteString.Lazy qualified as BL
import Data.IORef
import Data.Map.Strict qualified as Map
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Vector qualified as V
import System.Directory (doesFileExist)
import System.Exit (ExitCode (..), exitFailure, exitSuccess)
import System.IO
import System.Process
import Data.Reflection (Given (..))
import Proto (decodeMessage)
import Proto (encodeMessage)
import Proto.IDL.Descriptor (serializeFileDescriptor)
import Proto.IDL.Parser (parseProtoFile)
import Proto.Internal.JSON.Extension (ExtensionRegistry, emptyExtensionRegistry)
import Proto.TH.QQ (proto)
-- Satisfy the Given ExtensionRegistry constraint used by the
-- ToJSON / FromJSON instances generated by [proto|...|].
-- An empty registry is correct for proto3 messages which have no extensions.
instance Given ExtensionRegistry where
given = emptyExtensionRegistry
-- ---------------------------------------------------------------------------
-- Generated types (inline quasi-quoter so no file path is needed at runtime)
-- ---------------------------------------------------------------------------
[proto|
syntax = "proto3";
package test.interop;
enum Priority {
PRIORITY_UNSPECIFIED = 0;
PRIORITY_LOW = 1;
PRIORITY_HIGH = 2;
}
message Address {
string street = 1;
string city = 2;
string country = 3;
}
message Person {
string name = 1;
int32 age = 2;
bool active = 3;
double score = 4;
bytes payload = 5;
Priority priority = 6;
Address address = 7;
repeated string tags = 8;
map<string, int32> ratings = 9;
optional string nickname = 10;
}
message NumberKinds {
int32 i32 = 1;
int64 i64 = 2;
uint32 u32 = 3;
uint64 u64 = 4;
sint32 s32 = 5;
sint64 s64 = 6;
float f32 = 7;
double f64 = 8;
fixed32 fx32 = 9;
fixed64 fx64 = 10;
sfixed32 sf32 = 11;
sfixed64 sf64 = 12;
}
|]
-- ---------------------------------------------------------------------------
-- Protocol helpers
-- ---------------------------------------------------------------------------
sendJSON :: Handle -> A.Value -> IO ()
sendJSON h v = do
BS.hPut h (BL.toStrict (A.encode v))
BS.hPut h "\n"
hFlush h
recvJSON :: Handle -> IO (Either String A.Value)
recvJSON h = do
line <- hGetLine h
pure (A.eitherDecodeStrict (TE.encodeUtf8 (T.pack line)))
b64Encode :: ByteString -> Text
b64Encode = TE.decodeUtf8 . B64.encode
b64Decode :: Text -> Either String ByteString
b64Decode t = case B64.decode (TE.encodeUtf8 t) of
Left e -> Left (show e)
Right b -> Right b
-- | Parse the 'status', optional 'data', and optional 'message' fields from
-- a JSON response object. All other shapes are an error.
parseResp :: A.Value -> Either String (Text, Maybe Text, Maybe Text)
parseResp = AT.parseEither $
A.withObject "response" $ \o -> do
status <- o A..: "status"
dat <- o A..:? "data"
msg <- o A..:? "message"
pure (status, dat, msg)
-- ---------------------------------------------------------------------------
-- Driver lifecycle
-- ---------------------------------------------------------------------------
data PythonDriver = PythonDriver
{ pdIn :: Handle
, pdOut :: Handle
}
initDriver :: FilePath -> IO PythonDriver
initDriver driverPath = do
(Just hin, Just hout, _, _) <-
createProcess
(proc "python3" [driverPath])
{ std_in = CreatePipe
, std_out = CreatePipe
, std_err = Inherit
}
hSetBuffering hin LineBuffering
hSetBuffering hout LineBuffering
pure (PythonDriver hin hout)
-- | Send the FileDescriptorProto so Python can register the message types.
initSchema :: PythonDriver -> IO ()
initSchema pd = do
let protoSrc =
T.unlines
[ "syntax = \"proto3\";"
, "package test.interop;"
, "enum Priority { PRIORITY_UNSPECIFIED = 0; PRIORITY_LOW = 1; PRIORITY_HIGH = 2; }"
, "message Address { string street = 1; string city = 2; string country = 3; }"
, "message Person {"
, " string name = 1; int32 age = 2; bool active = 3; double score = 4;"
, " bytes payload = 5; Priority priority = 6; Address address = 7;"
, " repeated string tags = 8; map<string,int32> ratings = 9;"
, " optional string nickname = 10;"
, "}"
, "message NumberKinds {"
, " int32 i32 = 1; int64 i64 = 2; uint32 u32 = 3; uint64 u64 = 4;"
, " sint32 s32 = 5; sint64 s64 = 6; float f32 = 7; double f64 = 8;"
, " fixed32 fx32 = 9; fixed64 fx64 = 10; sfixed32 sf32 = 11; sfixed64 sf64 = 12;"
, "}"
]
case parseProtoFile "interop_fixture.proto" protoSrc of
Left e -> fail ("initSchema: parse failed: " <> show e)
Right pf -> do
let schemaBytes = serializeFileDescriptor "interop_fixture.proto" pf
sendJSON (pdIn pd) $
A.object ["type" .= ("init" :: Text), "schema" .= b64Encode schemaBytes]
resp <- recvJSON (pdOut pd)
case resp >>= parseResp of
Right ("ready", _, _) -> pure ()
Right ("error", _, Just msg) -> fail ("initSchema: Python error: " <> T.unpack msg)
Right (other, _, _) -> fail ("initSchema: unexpected status: " <> T.unpack other)
Left e -> fail ("initSchema: parse error: " <> e)
-- ---------------------------------------------------------------------------
-- Test harness
-- ---------------------------------------------------------------------------
data Result = Pass | Fail String deriving (Eq)
type Test = PythonDriver -> IO Result
runTest :: String -> Test -> PythonDriver -> IORef Int -> IORef Int -> IO ()
runTest name test pd passRef failRef = do
result <- try @SomeException (test pd)
case result of
Left e -> do
modifyIORef' failRef (+1)
putStrLn $ " FAIL " <> name
putStrLn $ " exception: " <> show e
Right (Fail msg) -> do
modifyIORef' failRef (+1)
putStrLn $ " FAIL " <> name
putStrLn $ " " <> msg
Right Pass -> do
modifyIORef' passRef (+1)
putStrLn $ " OK " <> name
-- | Send bytes from Haskell, have Python decode and re-encode, then
-- decode the Python output in Haskell and check field values.
-- Comparing raw bytes is wrong for map fields since entry ordering
-- is not guaranteed by the wire format.
h2p
:: Text
-> ByteString
-> (ByteString -> Either String ())
-- ^ Check the Python-re-encoded bytes by decoding in Haskell.
-> PythonDriver
-> IO Result
h2p msgType hsBytes check pd = do
sendJSON (pdIn pd) $
A.object
[ "type" .= ("h2p" :: Text)
, "msg" .= msgType
, "data" .= b64Encode hsBytes
]
resp <- recvJSON (pdOut pd)
case resp >>= parseResp of
Right ("ok", Just pyB64, _) ->
case b64Decode pyB64 of
Left e -> pure (Fail ("base64 decode: " <> e))
Right pyBytes -> case check pyBytes of
Left e -> pure (Fail e)
Right () -> pure Pass
Right ("error", _, Just msg) -> pure (Fail ("Python error: " <> T.unpack msg))
Right (other, _, _) -> pure (Fail ("unexpected status: " <> T.unpack other))
Left e -> pure (Fail ("response parse error: " <> e))
-- | Have Python encode from a field spec, decode in Haskell, check fields.
p2h :: Text -> A.Value -> (ByteString -> Either String ()) -> PythonDriver -> IO Result
p2h msgType fields check pd = do
sendJSON (pdIn pd) $
A.object
[ "type" .= ("p2h" :: Text)
, "msg" .= msgType
, "fields" .= fields
]
resp <- recvJSON (pdOut pd)
case resp >>= parseResp of
Right ("ok", Just pyB64, _) ->
case b64Decode pyB64 of
Left e -> pure (Fail ("base64 decode: " <> e))
Right pyBytes -> case check pyBytes of
Left e -> pure (Fail e)
Right () -> pure Pass
Right ("error", _, Just msg) -> pure (Fail ("Python error: " <> T.unpack msg))
Right (other, _, _) -> pure (Fail ("unexpected status: " <> T.unpack other))
Left e -> pure (Fail ("response parse error: " <> e))
-- ---------------------------------------------------------------------------
-- Test cases
-- ---------------------------------------------------------------------------
-- | Bidirectional test: Haskell encodes, Python re-encodes (bytes must match),
-- then Python encodes from the same spec and Haskell decodes + checks.
testPerson :: Test
testPerson pd = do
let hs =
defaultPerson
{ personName = "Alice"
, personAge = 30
, personActive = True
, personScore = 3.14
, personPayload = "\x00\x01\x02\x03"
, personPriority = Priority'PriorityHigh
, personAddress =
Just
defaultAddress
{ addressStreet = "123 Main St"
, addressCity = "Springfield"
, addressCountry = "US"
}
, personTags = V.fromList ["haskell", "protobuf", "interop"]
, personRatings = Map.fromList [("speed", 9), ("clarity", 8)]
, personNickname = Just "Al"
}
hsBytes = encodeMessage hs
fields =
A.object
[ "name" .= ("Alice" :: Text)
, "age" .= (30 :: Int)
, "active" .= True
, "score" .= (3.14 :: Double)
, "payload" .= A.object ["__bytes__" .= ("AAECAw==" :: Text)]
, "priority" .= (2 :: Int) -- PRIORITY_HIGH
, "address" .= A.object
[ "street" .= ("123 Main St" :: Text)
, "city" .= ("Springfield" :: Text)
, "country" .= ("US" :: Text)
]
, "tags" .= (["haskell", "protobuf", "interop"] :: [Text])
, "ratings" .= A.object ["speed" .= (9 :: Int), "clarity" .= (8 :: Int)]
, "nickname" .= ("Al" :: Text)
]
r1 <- h2p "test.interop.Person" hsBytes checkPerson pd
case r1 of
Fail msg -> pure (Fail ("h2p failed: " <> msg))
Pass -> p2h "test.interop.Person" fields checkPerson pd
where
checkPerson bytes = case decodeMessage @Person bytes of
Left e -> Left ("decode failed: " <> show e)
Right p -> do
check "name" (personName p == "Alice") "expected \"Alice\""
check "age" (personAge p == 30) "expected 30"
check "active" (personActive p == True) "expected True"
check "score" (abs (personScore p - 3.14) < 1e-10) "expected ~3.14"
check "payload" (personPayload p == "\x00\x01\x02\x03") "expected [0,1,2,3]"
check "priority" (personPriority p == Priority'PriorityHigh) "expected PRIORITY_HIGH"
check "address.city" (fmap addressCity (personAddress p) == Just "Springfield") "expected Springfield"
check "tags length" (length (personTags p) == 3) "expected 3 tags"
check "ratings[speed]" (Map.lookup "speed" (personRatings p) == Just 9) "expected 9"
check "nickname" (personNickname p == Just "Al") "expected Just \"Al\""
check _ True _ = Right ()
check field False msg = Left ("field " <> field <> ": " <> msg)
testEmptyMessage :: Test
testEmptyMessage pd = do
let hs = defaultPerson
hsBytes = encodeMessage hs
r1 <- h2p "test.interop.Person" hsBytes checkEmpty pd
case r1 of
Fail msg -> pure (Fail ("h2p empty failed: " <> msg))
Pass -> p2h "test.interop.Person" (A.object []) checkEmpty pd
where
checkEmpty bytes = case decodeMessage @Person bytes of
Left e -> Left ("decode failed: " <> show e)
Right p -> do
if personName p == "" && personAge p == 0 && personActive p == False
then Right ()
else Left "default values wrong"
testNumberKinds :: Test
testNumberKinds pd = do
let hs =
defaultNumberKinds
{ numberKindsI32 = -1
, numberKindsI64 = -1000000000000
, numberKindsU32 = maxBound
, numberKindsU64 = maxBound
, numberKindsS32 = -500
, numberKindsS64 = -5000000000
, numberKindsF32 = 1.5
, numberKindsF64 = 2.718281828
, numberKindsFx32 = 42
, numberKindsFx64 = 123456
, numberKindsSf32 = -42
, numberKindsSf64 = -123456
}
hsBytes = encodeMessage hs
fields =
A.object
[ "i32" .= (-1 :: Int)
, "i64" .= (-1000000000000 :: Integer)
, "u32" .= (4294967295 :: Integer) -- maxBound @Word32
, "u64" .= (18446744073709551615 :: Integer) -- maxBound @Word64
, "s32" .= (-500 :: Int)
, "s64" .= (-5000000000 :: Integer)
, "f32" .= (1.5 :: Double)
, "f64" .= (2.718281828 :: Double)
, "fx32" .= (42 :: Int)
, "fx64" .= (123456 :: Int)
, "sf32" .= (-42 :: Int)
, "sf64" .= (-123456 :: Int)
]
r1 <- h2p "test.interop.NumberKinds" hsBytes checkNumbers pd
case r1 of
Fail msg -> pure (Fail ("h2p numbers failed: " <> msg))
Pass -> p2h "test.interop.NumberKinds" fields checkNumbers pd
where
checkNumbers bytes = case decodeMessage @NumberKinds bytes of
Left e -> Left ("decode failed: " <> show e)
Right n -> do
check "i32" (numberKindsI32 n == -1) "expected -1"
check "i64" (numberKindsI64 n == -1000000000000) "expected -1000000000000"
check "u32" (numberKindsU32 n == maxBound) "expected maxBound"
check "u64" (numberKindsU64 n == maxBound) "expected maxBound"
check "s32" (numberKindsS32 n == -500) "expected -500"
check "s64" (numberKindsS64 n == -5000000000) "expected -5000000000"
check "f32" (abs (numberKindsF32 n - 1.5) < 1e-5) "expected ~1.5"
check "f64" (abs (numberKindsF64 n - 2.718281828) < 1e-10) "expected ~2.718..."
check "fx32" (numberKindsFx32 n == 42) "expected 42"
check "fx64" (numberKindsFx64 n == 123456) "expected 123456"
check "sf32" (numberKindsSf32 n == -42) "expected -42"
check "sf64" (numberKindsSf64 n == -123456) "expected -123456"
check _ True _ = Right ()
check field False msg = Left ("field " <> field <> ": " <> msg)
testOptionalPresence :: Test
testOptionalPresence pd = do
-- Absent optional: no nickname field → Nothing
let absentCheck bytes = case decodeMessage @Person bytes of
Left e -> Left ("decode failed: " <> show e)
Right p ->
if personNickname p == Nothing
then Right ()
else Left ("expected Nothing, got " <> show (personNickname p))
r1 <- p2h "test.interop.Person" (A.object []) absentCheck pd
case r1 of
Fail msg -> pure (Fail ("absent optional failed: " <> msg))
Pass -> do
-- Present optional with non-empty value → Just "Nikki"
-- (empty string is ambiguous in proto3 JSON: json_format may omit it)
let presentCheck bytes = case decodeMessage @Person bytes of
Left e -> Left ("decode failed: " <> show e)
Right p ->
if personNickname p == Just "Nikki"
then Right ()
else Left ("expected Just \"Nikki\", got " <> show (personNickname p))
hsPresent = defaultPerson{personNickname = Just "Nikki"}
hsBytesPresent = encodeMessage hsPresent
r2 <- h2p "test.interop.Person" hsBytesPresent presentCheck pd
case r2 of
Fail msg -> pure (Fail ("h2p present optional failed: " <> msg))
Pass -> p2h "test.interop.Person" (A.object ["nickname" .= ("Nikki" :: Text)]) presentCheck pd
-- ---------------------------------------------------------------------------
-- Entry point
-- ---------------------------------------------------------------------------
main :: IO ()
main = do
-- Verify python3 actually runs. In some environments (e.g. nix devshells)
-- the binary exists at /usr/bin/python3 but is blocked at exec time.
pyOk <- try @SomeException (readProcessWithExitCode "python3" ["--version"] "")
case pyOk of
Left _ -> do
putStrLn "SKIP: python3 not runnable in this environment"
exitSuccess
Right (ExitFailure _, _, _) -> do
putStrLn "SKIP: python3 --version returned non-zero"
exitSuccess
Right (ExitSuccess, _, _) -> pure ()
driver <- do
let candidates =
[ "python-interop/driver.py"
, "wireform-proto/python-interop/driver.py"
]
firstExisting [] = fail "Could not find python-interop/driver.py"
firstExisting (p : ps) = do
exists <- doesFileExist p
if exists then pure p else firstExisting ps
firstExisting candidates
pd <- initDriver driver
-- Check google-protobuf is installed (init will fail fast with a clear message).
result <- try @SomeException (initSchema pd)
case result of
Left e -> do
let msg = show e
if "google-protobuf not installed" `T.isInfixOf` T.pack msg
then do
putStrLn "SKIP: google-protobuf not installed (pip install protobuf)"
exitSuccess
else do
putStrLn $ "FAIL: schema init: " <> msg
exitFailure
Right () -> pure ()
passRef <- newIORef (0 :: Int)
failRef <- newIORef (0 :: Int)
putStrLn "wireform-proto ↔ google-protobuf interop"
putStrLn ""
let run name test = runTest name test pd passRef failRef
run "Person round-trip (full)" testPerson
run "Person empty message" testEmptyMessage
run "NumberKinds all scalar types" testNumberKinds
run "Optional field presence" testOptionalPresence
sendJSON (pdIn pd) (A.object ["type" .= ("done" :: Text)])
passes <- readIORef passRef
fails <- readIORef failRef
putStrLn ""
putStrLn $ show passes <> " passed, " <> show fails <> " failed"
if fails > 0 then exitFailure else exitSuccess