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
|
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
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)
import GTFS.Realtime.Alert as AL (Alert (..))
import GTFS.Realtime.Alert.Cause (Cause (CONSTRUCTION))
import GTFS.Realtime.Alert.Effect (Effect (DETOUR))
import GTFS.Realtime.Alert.SeverityLevel (SeverityLevel (WARNING))
import GTFS.Realtime.EntitySelector as ES (EntitySelector (..))
import GTFS.Realtime.FeedEntity as FE (FeedEntity (..))
import GTFS.Realtime.FeedHeader (FeedHeader (FeedHeader))
import GTFS.Realtime.FeedHeader.Incrementality (Incrementality (FULL_DATASET))
import GTFS.Realtime.FeedMessage as FM (FeedMessage (..))
import GTFS.Realtime.TimeRange (TimeRange (TimeRange))
import GTFS.Realtime.TranslatedString (TranslatedString (TranslatedString))
import GTFS.Realtime.TranslatedString.Translation (Translation (Translation))
import GTFS.Realtime.TripDescriptor as TD (TripDescriptor (..))
import Prelude hiding (id)
import Text.ProtocolBuffers (Utf8 (Utf8),
defaultValue)
import Text.ProtocolBuffers.WireMessage (zzEncode64)
import API (GtfsRealtimeAPI)
import Control.Monad.IO.Class (MonadIO (..))
import Data.ByteString.Lazy (fromStrict)
import Data.Functor ((<&>))
import Data.Pool (Pool)
import Data.Sequence (Seq)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Time (Day)
import Data.Time.Calendar (Day, toGregorian)
import qualified Data.UUID as UUID
import Database.Persist (Entity (Entity),
selectList)
import Database.Persist.Postgresql (SqlBackend)
import GTFS (GTFS)
import Persist (Announcement (..),
Key (..),
RunningTrip,
runSql)
import Servant.API ((:<|>) (..))
import Servant.Server (Handler (Handler),
Server)
uuidUtf8 :: UUID.UUID -> Utf8
uuidUtf8 = Utf8 . fromStrict . UUID.toASCIIBytes
toUtf8 :: Text -> Utf8
toUtf8 = Utf8 . fromStrict . encodeUtf8
-- | formats a day in the "stupid" format used by gtfs realtime
toStupidDate :: Day -> Utf8
toStupidDate date = toUtf8
$ 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)
gtfsRealtimeServer :: GTFS -> Pool SqlBackend -> Server GtfsRealtimeAPI
gtfsRealtimeServer gtfs dbpool = handleServiceAlerts :<|> handleTripUpdates :<|> handleVehiclePositions
where handleServiceAlerts = runSql dbpool $ do
-- TODO filter: only select current & future days
announcements <- selectList [] []
dFeedMessage $ Seq.fromList $ fmap mkAlert announcements
where mkAlert (Entity (AnnouncementKey uuid) Announcement{..}) =
(dFeedEntity (uuidUtf8 uuid))
{ alert =
(Just $ Alert
{ active_period = [TimeRange Nothing Nothing defaultValue]
-- 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
})
}
]
, cause = Nothing
, effect = Nothing
, url = fmap (lang "de" . toUtf8) announcementUrl
, header_text = Just $ lang "de" (toUtf8 announcementHeader)
, description_text = Just $ lang "de" (toUtf8 announcementMessage)
, tts_header_text = Nothing
, tts_description_text = Nothing
, severity_level = Nothing
, image = Nothing
, image_alternative_text = Nothing
, AL.ext'field = defaultValue
}) }
handleTripUpdates = runSql dbpool $ do
-- 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
lang :: Utf8 -> Utf8 -> TranslatedString
lang code msg = TranslatedString [Translation msg (Just code) defaultValue] defaultValue
-- | a default FeedMessage, issued at the current system time
-- TODO: do we ever need incremental updates?
-- TODO: maybe instead use last update time?
dFeedMessage :: MonadIO m => Seq FeedEntity -> m FeedMessage
dFeedMessage entities = do
now <- liftIO getSystemTime <&> systemSeconds
pure $ FeedMessage
{ header = FeedHeader "2.0" (Just FULL_DATASET) (Just $ fromIntegral now) defaultValue
, entity = entities
, FM.ext'field = defaultValue
}
-- | a dummy FeedEntity (use record updates to add meaningful values to this)
dFeedEntity :: Utf8 -> FeedEntity
dFeedEntity id = FeedEntity
{ id
, is_deleted = Nothing
, trip_update = Nothing
, vehicle = Nothing
, alert = Nothing
, shape = Nothing
, FE.ext'field = defaultValue
}
dEntitySelector :: EntitySelector
dEntitySelector = EntitySelector
{ agency_id = Nothing
, route_id = Nothing
, route_type = Nothing
, trip = Nothing
, stop_id = Nothing
, direction_id = Nothing
, ES.ext'field = defaultValue
}
|
