1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DataKinds #-}
module Server.GTFS_RT (gtfsRealtimeServer) where
import API (GtfsRealtimeAPI)
import Control.Lens ((&), (.~))
import Control.Monad (forM)
import Control.Monad.Extra (mapMaybeM)
import Control.Monad.IO.Class (MonadIO (..))
import Data.Functor ((<&>))
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import qualified Data.Map as M
import Data.Maybe (catMaybes, mapMaybe)
import Data.Pool (Pool)
import Data.ProtoLens (defMessage)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar (Day, toGregorian)
import Data.Time.Clock (UTCTime (utctDay), addUTCTime,
getCurrentTime)
import Data.Time.Clock.System (SystemTime (systemSeconds),
getSystemTime, utcToSystemTime)
import Data.Time.Format.ISO8601 (iso8601Show)
import Data.UUID (toASCIIBytes, toLazyASCIIBytes)
import qualified Data.UUID as UUID
import qualified Data.Vector as V
import Database.Persist (Entity (..),
PersistQueryRead (selectFirst),
selectList, (==.))
import Database.Persist.Postgresql (SqlBackend)
import Extrapolation (Extrapolator (extrapolateAtPosition, extrapolateAtSeconds),
LinearExtrapolator (..))
import GHC.Float (double2Float, int2Double)
import GTFS (Depth (..), GTFS (..),
Seconds (..), Stop (..),
Trip (..), TripID,
showTimeWithSeconds, stationId,
toSeconds, toUTC, tripsOnDay)
import Persist (Announcement (..),
EntityField (..), Key (..),
Running (..), Token (..),
TrainAnchor (..), TrainPing (..),
runSql)
import qualified Proto.GtfsRealtime as RT
import qualified Proto.GtfsRealtime_Fields as RT
import Servant.API ((:<|>) (..))
import Server.Util (Service, secondsNow)
-- | formats a day in the "stupid" format used by gtfs realtime
toStupidDate :: Day -> Text
toStupidDate date =
pad 4 year <> pad 2 month <> pad 2 day
where (year, month, day) = toGregorian date
pad len num = T.pack $ if ndigits < len
then replicate (len - ndigits) '0' <> show num
else show num
where ndigits = length (show num)
-- | basically unix timestamps, raw (because why not i guess)
toStupidTime :: Num i => UTCTime -> i
toStupidTime = fromIntegral . systemSeconds . utcToSystemTime
gtfsRealtimeServer :: GTFS -> Pool SqlBackend -> Service GtfsRealtimeAPI
gtfsRealtimeServer gtfs@GTFS{..} dbpool =
handleServiceAlerts :<|> handleTripUpdates :<|> handleVehiclePositions
where
handleServiceAlerts = runSql dbpool $ do
announcements <- selectList [] []
defFeedMessage (fmap mkAlert announcements)
where
mkAlert :: Entity Announcement -> RT.FeedEntity
mkAlert (Entity (AnnouncementKey uuid) Announcement{..}) =
defMessage
& RT.id .~ UUID.toText uuid
& RT.alert .~ (defMessage
& RT.activePeriod .~ [ defMessage :: RT.TimeRange ]
& RT.informedEntity .~ [ defMessage
& RT.trip .~ defTripDescriptor announcementTrip (Just announcementDay) Nothing
]
& RT.maybe'url .~ fmap (monolingual "de") announcementUrl
& RT.headerText .~ monolingual "de" announcementHeader
& RT.descriptionText .~ monolingual "de" announcementMessage
)
handleTripUpdates = runSql dbpool $ do
today <- liftIO $ getCurrentTime <&> utctDay
nowSeconds <- secondsNow today
let running = M.toList (tripsOnDay gtfs today)
anchors <- flip mapMaybeM running $ \(tripId, trip@Trip{..}) -> do
entities <- selectList [TrainAnchorTrip ==. tripId, TrainAnchorDay ==. today] []
case nonEmpty (fmap entityVal entities) of
Nothing -> pure Nothing
Just anchors -> pure $ Just (tripId, trip, anchors)
defFeedMessage (mapMaybe (mkTripUpdate today nowSeconds) anchors)
where
mkTripUpdate :: Day -> Seconds -> (Text, Trip 'Deep 'Deep, NonEmpty TrainAnchor) -> Maybe RT.FeedEntity
mkTripUpdate today nowSeconds (tripId :: Text, Trip{..} :: Trip Deep Deep, anchors) =
let lastCall = extrapolateAtSeconds LinearExtrapolator anchors nowSeconds
stations = tripStops
<&> (\stop@Stop{..} -> (, stop)
<$> extrapolateAtPosition LinearExtrapolator anchors (int2Double stopSequence))
(lastAnchor, lastStop) = V.last (V.catMaybes stations)
stillRunning = trainAnchorDelay lastAnchor + toSeconds (stopArrival lastStop) tzseries today
< nowSeconds + 5 * 60
in if not stillRunning then Nothing else Just $ defMessage
& RT.id .~ (tripId <> "-" <> T.pack (iso8601Show today))
& RT.tripUpdate .~ (defMessage
& RT.trip .~ defTripDescriptor tripId (Just today) (Just $ T.pack (showTimeWithSeconds $ stopDeparture $ V.head tripStops))
& RT.stopTimeUpdate .~ fmap mkStopTimeUpdate (catMaybes $ V.toList stations)
& RT.maybe'delay .~ Nothing -- lastCall <&> (fromIntegral . unSeconds . trainAnchorDelay)
& RT.maybe'timestamp .~ fmap (toStupidTime . trainAnchorCreated) lastCall
)
where
mkStopTimeUpdate :: (TrainAnchor, Stop Deep) -> RT.TripUpdate'StopTimeUpdate
mkStopTimeUpdate (TrainAnchor{..}, Stop{..}) = defMessage
& RT.stopSequence .~ fromIntegral stopSequence
& RT.stopId .~ stationId stopStation
& RT.arrival .~ (defMessage
& RT.delay .~ fromIntegral (unSeconds trainAnchorDelay)
& RT.time .~ toStupidTime (addUTCTime
(fromIntegral $ unSeconds trainAnchorDelay)
(toUTC stopArrival tzseries today))
& RT.uncertainty .~ 60
)
& RT.departure .~ (defMessage
& RT.delay .~ fromIntegral (unSeconds trainAnchorDelay)
& RT.time .~ toStupidTime (addUTCTime
(fromIntegral $ unSeconds trainAnchorDelay)
(toUTC stopDeparture tzseries today))
& RT.uncertainty .~ 60
)
& RT.scheduleRelationship .~ RT.TripUpdate'StopTimeUpdate'SCHEDULED
handleVehiclePositions = runSql dbpool $ do
(running :: [Entity Running]) <- selectList [] []
pings <- forM running $ \(Entity key entity) -> do
selectFirst [TrainPingToken ==. key] [] <&> fmap (, entity)
defFeedMessage (mkPosition <$> catMaybes pings)
where
mkPosition :: (Entity TrainPing, Running) -> RT.FeedEntity
mkPosition (Entity (TrainPingKey key) TrainPing{..}, Running{..}) = defMessage
& RT.id .~ T.pack (show key)
& RT.vehicle .~ (defMessage
& RT.trip .~ defTripDescriptor runningTrip Nothing Nothing
& RT.maybe'vehicle .~ case runningVehicle of
Nothing -> Nothing
Just trainset -> Just $ defMessage
& RT.label .~ trainset
& RT.position .~ (defMessage
& RT.latitude .~ double2Float trainPingLat
& RT.longitude .~ double2Float trainPingLong
)
-- TODO: should probably give currentStopSequence/stopId here as well
& RT.timestamp .~ toStupidTime trainPingTimestamp
)
monolingual :: Text -> Text -> RT.TranslatedString
monolingual code msg = defMessage & RT.translation .~ [
defMessage
& RT.text .~ msg
& RT.language .~ code
]
defFeedMessage :: MonadIO m => [RT.FeedEntity] -> m RT.FeedMessage
defFeedMessage entities = do
now <- liftIO getSystemTime <&> systemSeconds
pure $ defMessage
& RT.header .~ (defMessage
& RT.gtfsRealtimeVersion .~ "2.0"
& RT.incrementality .~ RT.FeedHeader'FULL_DATASET
& RT.timestamp .~ fromIntegral now
)
& RT.entity .~ entities
defTripDescriptor :: TripID -> Maybe Day -> Maybe Text -> RT.TripDescriptor
defTripDescriptor tripId day starttime = defMessage
& RT.tripId .~ tripId
& RT.scheduleRelationship .~ RT.TripDescriptor'SCHEDULED
& RT.maybe'startTime .~ starttime
& RT.maybe'startDate .~ fmap toStupidDate day
|
