gtfs realtime: add vehicle positions

(or at least something that looks like it might be correct — though
it carries very little information, and lacks things like what the next
stop along the route is)

3 files changed, 71 insertions, 17 deletions

diff --git a/lib/Persist.hs b/lib/Persist.hs
index 552074f..e73b74f 100644
--- a/lib/Persist.hs
+++ b/lib/Persist.hs
@@ -68,6 +68,7 @@ RunningTrip sql=tt_tracker_token
   expires UTCTime
   blocked Bool
   tripNumber Text
+  trainset Text Maybe
   deriving Eq Show Generic
 
 TripPing json sql=tt_trip_ping
diff --git a/lib/Server.hs b/lib/Server.hs
index 6c293f0..5ece540 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -91,8 +91,9 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> handleStations :<|> handleTime
           Just res -> pure res
           Nothing  -> throwError err404
         handleRegister tripID = do
+          -- TODO registration may carry extra information!
           expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod
-          RunningTripKey token <- runSql dbpool $ insert (RunningTrip expires False tripID)
+          RunningTripKey token <- runSql dbpool $ insert (RunningTrip expires False tripID Nothing)
           pure token
         handleTripPing ping = do
           checkTokenValid dbpool (coerce $ tripPingToken ping)
diff --git a/lib/Server/GTFSRT.hs b/lib/Server/GTFSRT.hs
index 7035ccf..0a654c6 100644
--- a/lib/Server/GTFSRT.hs
+++ b/lib/Server/GTFSRT.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE OverloadedLists   #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TupleSections     #-}
 {-# LANGUAGE TypeApplications  #-}
 
 module Server.GTFSRT (gtfsRealtimeServer) where
@@ -9,7 +10,8 @@ module Server.GTFSRT (gtfsRealtimeServer) where
 import qualified Data.Sequence                              as Seq
 import           Data.Time.Clock.POSIX                      (getPOSIXTime)
 import           Data.Time.Clock.System                     (SystemTime (systemSeconds),
-                                                             getSystemTime)
+                                                             getSystemTime,
+                                                             utcToSystemTime)
 import           GTFS.Realtime.Alert                        as AL (Alert (..))
 import           GTFS.Realtime.Alert.Cause                  (Cause (CONSTRUCTION))
 import           GTFS.Realtime.Alert.Effect                 (Effect (DETOUR))
@@ -29,9 +31,11 @@ import           Text.ProtocolBuffers                       (Utf8 (Utf8),
 import           Text.ProtocolBuffers.WireMessage           (zzEncode64)
 
 import           API                                        (GtfsRealtimeAPI)
+import           Control.Monad                              (forM)
 import           Control.Monad.IO.Class                     (MonadIO (..))
 import           Data.ByteString.Lazy                       (fromStrict)
 import           Data.Functor                               ((<&>))
+import           Data.Maybe                                 (catMaybes)
 import           Data.Pool                                  (Pool)
 import           Data.Sequence                              (Seq)
 import           Data.Text                                  (Text)
@@ -39,14 +43,23 @@ import qualified Data.Text                                  as T
 import           Data.Text.Encoding                         (encodeUtf8)
 import           Data.Time                                  (Day)
 import           Data.Time.Calendar                         (Day, toGregorian)
+import           Data.Time.Clock                            (UTCTime)
 import qualified Data.UUID                                  as UUID
+import           Data.Word                                  (Word64)
 import           Database.Persist                           (Entity (Entity),
-                                                             selectList)
+                                                             PersistQueryRead (selectFirst),
+                                                             selectList, (==.))
 import           Database.Persist.Postgresql                (SqlBackend)
-import           GTFS                                       (GTFS)
+import           GHC.Float                                  (double2Float)
+import           GTFS                                       (GTFS, TripID)
+import           GTFS.Realtime.Position                     as POS (Position (..))
+import           GTFS.Realtime.VehicleDescriptor            as VD (VehicleDescriptor (..))
+import           GTFS.Realtime.VehiclePosition              as VP (VehiclePosition (..))
 import           Persist                                    (Announcement (..),
+                                                             EntityField (TripPingToken),
                                                              Key (..),
-                                                             RunningTrip,
+                                                             RunningTrip (..),
+                                                             TripPing (..),
                                                              runSql)
 import           Servant.API                                ((:<|>) (..))
 import           Servant.Server                             (Handler (Handler),
@@ -69,6 +82,9 @@ toStupidDate date = toUtf8
           else show num
           where ndigits = length (show num)
 
+-- | basically unix timestamps, raw (because why not i guess)
+toStupidTime :: UTCTime -> Word64
+toStupidTime = fromIntegral . systemSeconds . utcToSystemTime
 
 gtfsRealtimeServer :: GTFS -> Pool SqlBackend -> Server GtfsRealtimeAPI
 gtfsRealtimeServer gtfs dbpool = handleServiceAlerts :<|> handleTripUpdates :<|> handleVehiclePositions
@@ -84,16 +100,8 @@ gtfsRealtimeServer gtfs dbpool = handleServiceAlerts :<|> handleTripUpdates :<|>
                         -- TODO: is this time range reasonable, needed, etc.?
                         , informed_entity =
                           [dEntitySelector
-                           { trip =
-                             Just (TripDescriptor
-                             { trip_id = Just (toUtf8 announcementTrip)
-                             , route_id = Nothing
-                             , direction_id = Nothing
-                             , start_time = Nothing
-                             , start_date = Just (toStupidDate announcementDay)
-                             , schedule_relationship = Nothing
-                             , TD.ext'field = defaultValue
-                             })
+                           { ES.trip =
+                             Just (dTripDescriptor announcementTrip (Just announcementDay))
                            }
                           ]
                         , cause = Nothing
@@ -112,8 +120,41 @@ gtfsRealtimeServer gtfs dbpool = handleServiceAlerts :<|> handleTripUpdates :<|>
           -- TODO: how to propagate delay values to next stops?
           pure undefined
         handleVehiclePositions = runSql dbpool $ do
-          -- TODO: how to know which trips are currently running?
-          pure undefined
+          (running :: [Entity RunningTrip]) <- selectList [] []
+          pings <- forM running $ \(Entity key entity) -> do
+            selectFirst [TripPingToken ==. key] [] <&> fmap (, entity)
+          dFeedMessage $ Seq.fromList $ fmap mkPosition $ catMaybes pings
+          where mkPosition (Entity (TripPingKey key) TripPing{..}, RunningTrip{..}) =
+                  (dFeedEntity (toUtf8 . T.pack . show $ key))
+                  { FE.vehicle = Just $ VehiclePosition
+                    { trip = Just (dTripDescriptor runningTripTripNumber Nothing)
+                    , VP.vehicle = case runningTripTrainset of
+                        Nothing -> Nothing
+                        Just trainset -> Just $ VehicleDescriptor
+                             { VD.id = Nothing
+                             , VD.label = (Just (toUtf8 trainset))
+                             , VD.license_plate = Nothing
+                             , VD.ext'field = defaultValue
+                             }
+                    , position = Just $ Position
+                      { latitude = double2Float tripPingLat
+                      , longitude = double2Float tripPingLong
+                      , odometer = Nothing
+                      , speed = Nothing
+                      , bearing = Nothing
+                      , POS.ext'field = defaultValue
+                      }
+                    , current_stop_sequence = Nothing
+                    , stop_id = Nothing
+                    , current_status = Nothing
+                    , timestamp = Just (toStupidTime tripPingTimestamp)
+                    , congestion_level = Nothing
+                    , occupancy_status = Nothing
+                    , occupancy_percentage = Nothing
+                    , multi_carriage_details = []
+                    , VP.ext'field = defaultValue
+                    }
+                  }
 
 
 lang :: Utf8 -> Utf8 -> TranslatedString
@@ -153,3 +194,14 @@ dEntitySelector = EntitySelector
   , direction_id = Nothing
   , ES.ext'field = defaultValue
   }
+
+dTripDescriptor :: TripID -> Maybe Day -> TripDescriptor
+dTripDescriptor tripID day = TripDescriptor
+  { trip_id = Just (toUtf8 tripID)
+  , route_id = Nothing
+  , direction_id = Nothing
+  , start_time = Nothing
+  , start_date = fmap toStupidDate day
+  , schedule_relationship = Nothing
+  , TD.ext'field = defaultValue
+  }