1 files changed, 16 insertions, 2 deletions
diff --git a/lib/API.hs b/lib/API.hs
index b2635c1..7ebfb06 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -1,10 +1,11 @@
 {-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE DeriveAnyClass       #-}
 {-# LANGUAGE ExplicitNamespaces   #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 -- | The sole authorative definition of this server's API, given as a Servant-style
 -- Haskell type. All other descriptions of the API are generated from this one.
-module API (API, CompleteAPI, GtfsRealtimeAPI, RegisterJson(..), Metrics(..)) where
+module API (API, CompleteAPI, GtfsRealtimeAPI, RegisterJson(..), Metrics(..), SentPing(..)) where
 
 import           Data.Map                    (Map)
 import           Data.Proxy                  (Proxy (..))
@@ -51,12 +52,22 @@ import           Prometheus
 import           Proto.GtfsRealtime          (FeedMessage)
 import           Servant.API.ContentTypes    (Accept (..))
 
+-- | a bare ping as sent by a tracker device
+data SentPing = SentPing
+  { sentPingToken     :: TrackerId
+  , sentPingGeopos    :: Geopos
+  , sentPingTimestamp :: UTCTime
+  } deriving (Generic)
+
+instance FromJSON SentPing where
+  parseJSON = genericParseJSON (aesonOptions "sentPing")
+
 -- | tracktrain's API
 type API =
   -- ingress API (put this behind BasicAuth?)
   -- TODO: perhaps require a first ping for registration?
        "tracker" :> "register" :> ReqBody '[JSON] RegisterJson :> Post '[JSON] Token
-  :<|> "tracker" :> "ping" :> ReqBody '[JSON] TrainPing :> Post '[JSON] (Maybe TrainAnchor)
+  :<|> "tracker" :> "ping" :> ReqBody '[JSON] SentPing :> Post '[JSON] (Maybe TrainAnchor)
   :<|> "tracker" :> "ping" :> "ws" :> WebSocket
   :<|> "ticket" :> "subscribe" :> Capture "Ticket Id" UUID :> WebSocket
   :<|> "debug" :> "pings" :> Get '[JSON] (Map Token [TrainPing])
@@ -94,6 +105,8 @@ instance ToSchema RegisterJson where
 instance ToSchema Value where
   declareNamedSchema _ = pure $ NamedSchema (Just "json") $ mempty
       & type_ ?~ SwaggerObject
+instance ToSchema SentPing where
+  declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "trainPing")
 
 
 
@@ -124,3 +137,4 @@ instance Message msg => MimeRender Proto msg where
 instance {-# OVERLAPPABLE #-} Message msg => ToSchema msg where
   declareNamedSchema proxy =
     pure (NamedSchema (Just (messageName proxy)) mempty)
+