From 6c25964c0165530e7db6650eea79cbac99031353 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sat, 2 Jul 2022 00:16:02 +0200
Subject: gtfs realtime proof of concept

this adds a package for protobuf stuff, generated via hprotoc. Seems to
work kinda fine?

(the generated API is horrible though, will have to write some wrappers
for that)
---
 gtfs/Servant/GTFS/Realtime.hs | 38 ++++++++++++++++++++++++++++++++++++++
 1 file changed, 38 insertions(+)
 create mode 100644 gtfs/Servant/GTFS/Realtime.hs

(limited to 'gtfs/Servant/GTFS/Realtime.hs')

diff --git a/gtfs/Servant/GTFS/Realtime.hs b/gtfs/Servant/GTFS/Realtime.hs
new file mode 100644
index 0000000..8923b92
--- /dev/null
+++ b/gtfs/Servant/GTFS/Realtime.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+
+module Servant.GTFS.Realtime (Proto) where
+
+import Servant
+    ( MimeRender(..),
+      MimeUnrender(mimeUnrender),
+      Accept(contentType),
+      Proxy(Proxy) )
+import Text.ProtocolBuffers
+    ( Wire, ReflectDescriptor, messagePut, messageGet )
+import Network.HTTP.Media ((//))
+import Data.Either.Combinators (mapRight)
+import Data.Swagger (ToSchema(..))
+
+
+-- | A servant encoding for protobuf-encoded messages
+data Proto
+
+instance Accept Proto where
+  contentType _ = "application" // "octet-stream"
+
+instance (Wire msg, ReflectDescriptor msg) => MimeUnrender Proto msg where
+  mimeUnrender _ = mapRight fst . messageGet @msg
+
+instance (Wire msg, ReflectDescriptor msg) => MimeRender Proto msg where
+  mimeRender _ = messagePut
+
+-- TODO: this instance is horrible; ideally it should at least include
+-- the name of the message type (if at all possible)
+instance {-# OVERLAPPABLE #-} Wire msg => ToSchema msg where
+  declareNamedSchema _ = declareNamedSchema (Proxy @String)
-- 
cgit v1.2.3