aboutsummaryrefslogtreecommitdiff
path: root/lib/Server/GTFS_RT.hs
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Server/GTFS_RT.hs')
-rw-r--r--lib/Server/GTFS_RT.hs91
1 files changed, 42 insertions, 49 deletions
diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs
index 85ea8cd..e3a07cb 100644
--- a/lib/Server/GTFS_RT.hs
+++ b/lib/Server/GTFS_RT.hs
@@ -3,32 +3,10 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeApplications #-}
module Server.GTFS_RT (gtfsRealtimeServer) where
-import qualified Data.Sequence as Seq
-import Data.Time.Clock.POSIX (getPOSIXTime)
-import Data.Time.Clock.System (SystemTime (systemSeconds),
- getSystemTime,
- utcToSystemTime)
-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 (forM)
@@ -38,12 +16,16 @@ import Data.Functor ((<&>))
import Data.Maybe (catMaybes)
import Data.Pool (Pool)
import Data.Sequence (Seq)
+import qualified Data.Sequence as 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 Data.Time.Clock (UTCTime)
+import Data.Time.Clock.POSIX (getPOSIXTime)
+import Data.Time.Clock.System (SystemTime (systemSeconds),
+ getSystemTime,
+ utcToSystemTime)
import qualified Data.UUID as UUID
import Data.Word (Word64)
import Database.Persist (Entity (Entity),
@@ -52,18 +34,29 @@ import Database.Persist (Entity (Entity),
import Database.Persist.Postgresql (SqlBackend)
import GHC.Float (double2Float)
import GTFS (GTFS, TripID)
+import GTFS.Realtime.Alert as AL (Alert (..))
+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.Position as POS (Position (..))
+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 GTFS.Realtime.VehicleDescriptor as VD (VehicleDescriptor (..))
import GTFS.Realtime.VehiclePosition as VP (VehiclePosition (..))
import Persist (Announcement (..),
- EntityField (TripPingToken),
+ EntityField (..),
Key (..),
RunningTrip (..),
TripPing (..),
runSql)
import Servant.API ((:<|>) (..))
-import Servant.Server (Handler (Handler),
- Server)
+import Text.ProtocolBuffers (Utf8 (Utf8),
+ defaultValue)
import Server.Util (Service)
@@ -95,28 +88,28 @@ gtfsRealtimeServer gtfs dbpool = handleServiceAlerts :<|> handleTripUpdates :<|>
dFeedMessage $ Seq.fromList $ fmap mkAlert announcements
where mkAlert (Entity (AnnouncementKey uuid) Announcement{..}) =
(dFeedEntity (uuidUtf8 uuid))
- { alert =
- (Just $ Alert
- { active_period = [TimeRange Nothing Nothing defaultValue]
+ { alert = Just $ Alert
+ { active_period = [TimeRange Nothing Nothing defaultValue]
-- TODO: is this time range reasonable, needed, etc.?
- , informed_entity =
- [dEntitySelector
- { ES.trip =
- Just (dTripDescriptor announcementTrip (Just announcementDay))
- }
- ]
- , 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
- }) }
+ , informed_entity =
+ [dEntitySelector
+ { ES.trip =
+ Just (dTripDescriptor announcementTrip (Just announcementDay))
+ }
+ ]
+ , 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
error "unimplemented!"
-- TODO: how to propagate delay values to next stops?
@@ -125,7 +118,7 @@ gtfsRealtimeServer gtfs dbpool = handleServiceAlerts :<|> handleTripUpdates :<|>
(running :: [Entity RunningTrip]) <- selectList [] []
pings <- forM running $ \(Entity key entity) -> do
selectFirst [TripPingToken ==. key] [] <&> fmap (, entity)
- dFeedMessage $ Seq.fromList $ fmap mkPosition $ catMaybes pings
+ dFeedMessage $ Seq.fromList $ mkPosition <$> catMaybes pings
where mkPosition (Entity (TripPingKey key) TripPing{..}, RunningTrip{..}) =
(dFeedEntity (toUtf8 . T.pack . show $ key))
{ FE.vehicle = Just $ VehiclePosition
@@ -134,7 +127,7 @@ gtfsRealtimeServer gtfs dbpool = handleServiceAlerts :<|> handleTripUpdates :<|>
Nothing -> Nothing
Just trainset -> Just $ VehicleDescriptor
{ VD.id = Nothing
- , VD.label = (Just (toUtf8 trainset))
+ , VD.label = Just (toUtf8 trainset)
, VD.license_plate = Nothing
, VD.ext'field = defaultValue
}
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-19 20:02:36 +0000