diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/Persist.hs | 1 | ||||
| -rw-r--r-- | lib/Server.hs | 3 | ||||
| -rw-r--r-- | lib/Server/GTFSRT.hs | 84 |
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 + } |