aboutsummaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/Persist.hs1
-rw-r--r--lib/Server.hs3
-rw-r--r--lib/Server/GTFSRT.hs84
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
+ }