aboutsummaryrefslogtreecommitdiff
path: root/lib/Server/GTFS_RT.hs
blob: d2e53a1083f463c4ae24e27274cf056bca99a452 (plain)
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
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE TupleSections         #-}

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.Coerce                 (coerce)
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),
                                              SelectOpt (Asc, Desc), get,
                                              getJust, selectKeysList,
                                              selectList, (<-.), (==.))
import           Database.Persist.Postgresql (SqlBackend)
import           Extrapolation               (Extrapolator (extrapolateAtPosition, extrapolateAtSeconds),
                                              LinearExtrapolator (..))
import           GHC.Float                   (double2Float, int2Double)
import           GTFS                        (Depth (..), GTFS (..),
                                              Seconds (..), Trip (..), TripId,
                                              showTimeWithSeconds, stationId,
                                              toSeconds, toUTC, tripsOnDay)
import           Persist                     (Announcement (..),
                                              EntityField (..), Key (..),
                                              Station (..), Stop (..),
                                              Ticket (..), Token (..),
                                              Tracker (..), TrainAnchor (..),
                                              TrainPing (..), latitude,
                                              longitude, 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 [] []
      alerts <- forM announcements $ \(Entity (AnnouncementKey uuid) announcement@Announcement{..}) -> do
        ticket <- getJust announcementTicket
        pure $ mkAlert uuid announcement ticket
      defFeedMessage alerts

      where
        mkAlert :: UUID.UUID -> Announcement -> Ticket -> RT.FeedEntity
        mkAlert uuid Announcement{..} Ticket{..} =
              defMessage
              & RT.id .~ UUID.toText uuid
              & RT.alert .~ (defMessage
                  & RT.activePeriod .~ [ defMessage :: RT.TimeRange ]
                  & RT.informedEntity .~ [ defMessage
                       & RT.trip .~ defTripDescriptor ticketTripName (Just ticketDay) 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)
      tickets <- selectList [TicketCompleted ==. False] [Asc TicketTripName]

      tripUpdates <- forM tickets $ \(Entity key Ticket{..}) -> do
        selectList [TrainAnchorTicket ==. key] [] >>= \a -> case nonEmpty a of
          Nothing      -> pure Nothing
          Just anchors -> do
            stops <- selectList [StopTicket ==. key] [Asc StopArrival] >>= mapM (\(Entity _ stop) -> do
              station <- getJust (stopStation stop)
              pure (stop, station))

            let anchorEntities = fmap entityVal anchors
            let lastCall = extrapolateAtSeconds LinearExtrapolator anchorEntities nowSeconds
            let atStations = flip fmap stops $ \(stop, station) ->
                  (, stop, station) <$> extrapolateAtPosition LinearExtrapolator anchorEntities (int2Double (stopSequence stop))
            let (lastAnchor, lastStop, lastStation) = last (catMaybes atStations)
            let stillRunning = trainAnchorDelay lastAnchor + toSeconds (stopArrival lastStop) tzseries today
                    < nowSeconds + 5 * 60

            pure $ Just $ defMessage
              & RT.id .~ UUID.toText (coerce key)
              & RT.tripUpdate .~ (defMessage
                 & RT.trip .~
                   defTripDescriptor
                     ticketTripName (Just today)
                     (Just $ T.pack (showTimeWithSeconds $ stopDeparture $ fst $ head stops))
                 & RT.stopTimeUpdate .~ fmap mkStopTimeUpdate (catMaybes atStations)
                 & RT.maybe'delay .~ Nothing -- lastCall <&> (fromIntegral . unSeconds . trainAnchorDelay)
                 & RT.maybe'timestamp .~ fmap (toStupidTime . trainAnchorCreated) lastCall
              )
            where
              mkStopTimeUpdate :: (TrainAnchor, Stop, Station) -> RT.TripUpdate'StopTimeUpdate
              mkStopTimeUpdate (TrainAnchor{..}, Stop{..}, Station{..}) = defMessage
                & RT.stopSequence .~ fromIntegral stopSequence
                & RT.stopId .~ stationShortName
                & 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

      defFeedMessage (catMaybes tripUpdates)

    handleVehiclePositions = runSql dbpool $ do

      ticket <- selectList [TicketCompleted ==. False] []

      -- TODO: reimplement this (since trainpings no longer reference tickets it's gone for now)
      -- positions <- forM ticket $ \(Entity key ticket) -> do
      --   selectFirst [TrainPingTicket ==. key] [Desc TrainPingTimestamp] >>= \case
      --     Nothing -> pure Nothing
      --     Just lastPing ->
      --       pure (Just $ mkPosition (lastPing, ticket))

      defFeedMessage [] -- (catMaybes positions)

      where
        mkPosition :: (Entity TrainPing, Ticket) -> RT.FeedEntity
        mkPosition (Entity key TrainPing{..}, Ticket{..}) = defMessage
          & RT.id .~ T.pack (show key)
          & RT.vehicle .~ (defMessage
              & RT.trip .~ defTripDescriptor ticketTripName Nothing Nothing
              & RT.maybe'vehicle .~ case ticketVehicle of
                  Nothing -> Nothing
                  Just trainset -> Just $ defMessage
                    & RT.label .~ trainset
              & RT.position .~ (defMessage
                  & RT.latitude .~ double2Float (latitude trainPingGeopos)
                  & RT.longitude .~ double2Float (longitude trainPingGeopos)
              )
              -- 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