more or less functional servicealerts for gtfs rt

(kinda barebones, but the important things should be there)

5 files changed, 223 insertions, 98 deletions

diff --git a/lib/API.hs b/lib/API.hs
index 34b127a..5afd041 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -5,31 +5,33 @@
 
 -- | The sole authorative definition of this server's API, given as a Servant-style
 -- Haskell type. All other descriptions of the API are generated from this one.
-module API (API, CompleteAPI, GtfsRealtimeAPI) where
+module API (API, CompleteAPI, GtfsRealtimeAPI, AdminAPI) where
 
-import           Data.Map                 (Map)
-import           Data.Proxy               (Proxy (..))
-import           Data.Swagger             (Swagger)
-import           Data.Swagger.ParamSchema (ToParamSchema (..))
-import           Data.Time                (Day, UTCTime)
+import           Data.Map                  (Map)
+import           Data.Proxy                (Proxy (..))
+import           Data.Swagger              (Swagger)
+import           Data.Swagger.ParamSchema  (ToParamSchema (..))
+import           Data.Text                 (Text)
+import           Data.Time                 (Day, UTCTime)
 import           GTFS
+import           GTFS.Realtime.FeedEntity
+import           GTFS.Realtime.FeedMessage (FeedMessage)
 import           Persist
-import           Servant                  (Application,
-                                           FromHttpApiData (parseUrlPiece),
-                                           Server, err401, err404, serve,
-                                           throwError, type (:>))
-import           Servant.API              (Capture, FromHttpApiData, Get, JSON,
-                                           Post, QueryParam, ReqBody,
-                                           type (:<|>) ((:<|>)))
-import Servant.GTFS.Realtime (Proto)
-import GTFS.Realtime.FeedEntity
-import GTFS.Realtime.FeedMessage (FeedMessage)
+import           Servant                   (Application,
+                                            FromHttpApiData (parseUrlPiece),
+                                            Server, err401, err404, serve,
+                                            throwError, type (:>))
+import           Servant.API               (Capture, FromHttpApiData, Get, JSON,
+                                            Post, QueryParam, ReqBody,
+                                            type (:<|>) ((:<|>)))
+import           Servant.GTFS.Realtime     (Proto)
 
+import           Data.UUID                 (UUID)
 
 -- | The server's API (as it is actually intended).
 type API = "stations" :> Get '[JSON] (Map StationID Station)
-  :<|> "timetable" :> Capture "Station ID" StationID :> QueryParam "day" Day :> Get '[JSON] (Map TripID (Trip Deep))
-  :<|> "trip" :> Capture "Trip ID" TripID :> Get '[JSON] (Trip Deep)
+  :<|> "timetable" :> Capture "Station ID" StationID :> QueryParam "day" Day :> Get '[JSON] (Map TripID (Trip Deep Deep))
+  :<|> "trip" :> Capture "Trip ID" TripID :> Get '[JSON] (Trip Deep Deep)
   -- ingress API (put this behind BasicAuth?)
   -- TODO: perhaps require a first ping for registration?
   :<|> "train" :> "register" :> Capture "Trip ID" TripID :> Post '[JSON] Token
@@ -38,11 +40,22 @@ type API = "stations" :> Get '[JSON] (Map StationID Station)
   -- debug things
   :<|> "debug" :> "state" :> Get '[JSON] (Map Token [TripPing])
   :<|> "gtfs" :> GtfsRealtimeAPI
+  :<|> "admin" :> AdminAPI
 
 -- | The API used for publishing gtfs realtime updates
 type GtfsRealtimeAPI = "servicealerts" :> Get '[Proto] FeedMessage
-  :<|> "tripupdates" :> Get '[Proto] FeedEntity
-  :<|> "vehiclepositions" :> Get '[Proto] FeedEntity
+  :<|> "tripupdates" :> Get '[Proto] FeedMessage
+  :<|> "vehiclepositions" :> Get '[Proto] FeedMessage
+
+-- | Admin API used for short-term timetable changes etc. ("leitstelle")
+type AdminAPI =
+  "trip" :> "announce" :> Capture "Trip ID" TripID :> QueryParam "day" Day :> ReqBody '[JSON] Text :> Post '[JSON] UUID
+  :<|> "trip" :> "announce" :> "delete" :> Capture "Announcement ID" UUID :> Post '[JSON] ()
+  :<|> "trip" :> "date" :> "add" :> Capture "Trip ID" TripID :> Post '[JSON] ()
+  :<|> "trip" :> "date" :> "cancel" :> Capture "Trip ID" TripID :> Post '[JSON] ()
+-- TODO for this to be useful there ought to be a half-deep Trip type
+-- (that has stops but not shapes)
+  :<|> "extraordinary" :> "trip" :> ReqBody '[JSON] (Trip Deep Shallow) :> Post '[JSON] ()
 
 
 -- | The server's API with an additional debug route for accessing the specification
@@ -52,9 +65,12 @@ type CompleteAPI = "debug" :> "openapi" :> Get '[JSON] Swagger
   :<|> API
 
 
+
 instance ToParamSchema (Maybe UTCTime) where
   toParamSchema _ = toParamSchema (Proxy @UTCTime)
 
+
+
 {-
 TODO:
 there should be a basic API allowing the questions:
diff --git a/lib/GTFS.hs b/lib/GTFS.hs
index bd29b6d..68d92dc 100644
--- a/lib/GTFS.hs
+++ b/lib/GTFS.hs
@@ -189,7 +189,7 @@ instance FromJSON CalendarDate where
 instance ToJSON CalendarDate where
   toJSON = genericToJSON (aesonOptions "caldate")
 
-data Trip (deep :: Depth) = Trip
+data Trip (deep :: Depth) (shape :: Depth)= Trip
   { tripRoute     :: Text
   , tripTripID    :: TripID
   , tripHeadsign  :: Maybe Text
@@ -199,18 +199,21 @@ data Trip (deep :: Depth) = Trip
   , tripServiceId :: Text
   -- , tripWheelchairAccessible :: Bool
   -- , tripBikesAllowed :: Bool
-  , tripShape     :: Switch deep Shape Text
+  , tripShape     :: Switch shape Shape Text
   , tripStops     :: Optional deep (Vector (Stop deep))
   } deriving Generic
 
 
-deriving instance Show (Trip Shallow)
-deriving instance Show (Trip Deep)
-instance (FromJSON (Switch d Shape Text), FromJSON (Optional d (Vector (Stop d)))) => FromJSON (Trip d) where
+deriving instance Show (Trip Shallow Shallow)
+deriving instance Show (Trip Deep Deep)
+deriving instance Show (Trip Deep Shallow)
+instance (FromJSON (Switch d Shape Text), FromJSON (Optional d (Vector (Stop d))), FromJSON (Switch s Shape Text)) => FromJSON (Trip d s) where
   parseJSON = genericParseJSON (aesonOptions "trip")
-instance (ToJSON (Switch d Shape Text), ToJSON (Optional d (Vector (Stop d)))) => ToJSON (Trip d) where
+instance (ToJSON (Switch d Shape Text), ToJSON (Optional d (Vector (Stop d))), ToJSON (Switch s Shape Text)) => ToJSON (Trip d s) where
   toJSON = genericToJSON (aesonOptions "trip")
-instance ToSchema (Trip Deep) where
+instance ToSchema (Trip Deep Deep) where
+  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "trip")
+instance ToSchema (Trip Deep Shallow) where
   declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "trip")
 
 -- | helper function to find things in Vectors of things
@@ -297,7 +300,7 @@ instance CSV.FromNamedRecord CalendarDate where
         _ -> fail $ "unexpected value in exception_type: "+|int|+"."
 
 
-instance CSV.FromNamedRecord (Trip Shallow) where
+instance CSV.FromNamedRecord (Trip Shallow Shallow) where
   parseNamedRecord r = Trip
     <$> r .: "route_id"
     <*> r .: "trip_id"
@@ -314,7 +317,7 @@ instance CSV.FromNamedRecord (Trip Shallow) where
 data RawGTFS = RawGTFS
   { rawStations      :: Vector Station
   , rawStops         :: Vector (Stop Shallow)
-  , rawTrips         :: Vector (Trip Shallow)
+  , rawTrips         :: Vector (Trip Shallow Shallow)
   , rawCalendar      :: Maybe (Vector Calendar)
   , rawCalendarDates :: Maybe (Vector CalendarDate)
   , rawShapePoints   :: Maybe (Vector ShapePoint)
@@ -323,12 +326,12 @@ data RawGTFS = RawGTFS
 
 data GTFS = GTFS
   { stations      :: Map StationID Station
-  , trips         :: Map TripID (Trip Deep)
+  , trips         :: Map TripID (Trip Deep Deep)
   , calendar      :: Map DayOfWeek (Vector Calendar)
   , calendarDates :: Map Day (Vector CalendarDate)
   , shapes        :: Map Text Shape
 
-  , fancyCalendar :: Day -> (Vector ServiceID, Vector (Trip Deep))
+  , fancyCalendar :: Day -> (Vector ServiceID, Vector (Trip Deep Deep))
   -- ^ a more "fancy" encoding of the calendar?
   } -- deriving Show
 
@@ -400,7 +403,7 @@ loadGtfs path = do
           Just a -> pure a
           Nothing -> fail $ "station with id "+|stopStation stop|+"is mentioned but not defined."
         pure $ stop { stopStation = station }
-      pushTrip :: Vector (Stop Deep) -> Map Text Shape -> Trip Shallow -> IO (Trip Deep)
+      pushTrip :: Vector (Stop Deep) -> Map Text Shape -> Trip Shallow Shallow -> IO (Trip Deep Deep)
       pushTrip stops shapes trip = if V.length alongRoute < 2
           then fail $ "trip with id "+|tripTripID trip|+" has no stops"
           else do
@@ -430,7 +433,7 @@ servicesOnDay GTFS{..} day =
         notCancelled serviceID =
           null (tableLookup caldateServiceId serviceID removed)
 
-tripsOfService :: GTFS -> ServiceID -> Map TripID (Trip Deep)
+tripsOfService :: GTFS -> ServiceID -> Map TripID (Trip Deep Deep)
 tripsOfService GTFS{..} serviceId =
   M.filter (\trip -> tripServiceId trip == serviceId ) trips
 
@@ -440,5 +443,5 @@ tripsAtStation GTFS{..} at = fmap stopTrip stops
   where
     stops = V.filter (\(stop :: Stop Deep) -> stationId (stopStation stop) == at) stops
 
-tripsOnDay :: GTFS -> Day -> Map TripID (Trip Deep)
+tripsOnDay :: GTFS -> Day -> Map TripID (Trip Deep Deep)
 tripsOnDay gtfs today = foldMap (tripsOfService gtfs) (servicesOnDay gtfs today)
diff --git a/lib/Persist.hs b/lib/Persist.hs
index 4a6d9b4..552074f 100644
--- a/lib/Persist.hs
+++ b/lib/Persist.hs
@@ -78,10 +78,15 @@ TripPing json sql=tt_trip_ping
   timestamp UTCTime
   deriving Show Generic Eq
 
-Announcements sql=tt_announcements
+-- TODO: multi-language support?
+Announcement sql=tt_announcements
+  Id UUID default=uuid_generate_v4()
   trip TripID
   message Text
-  day Text
+  header Text
+  day Day
+  url Text Maybe
+  announcedAt UTCTime Maybe
 
 -- | this table works as calendar_dates.txt in GTFS
 ScheduleAmendment json sql=tt_schedule_amendement
diff --git a/lib/Server.hs b/lib/Server.hs
index 1aaf630..6c293f0 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -3,9 +3,9 @@
 {-# LANGUAGE FlexibleContexts   #-}
 {-# LANGUAGE FlexibleInstances  #-}
 {-# LANGUAGE LambdaCase         #-}
+{-# LANGUAGE OverloadedLists    #-}
 {-# LANGUAGE RecordWildCards    #-}
 {-# LANGUAGE TypeApplications   #-}
-{-# LANGUAGE OverloadedLists #-}
 
 
 -- Implementation of the API. This module is the main point of the program.
@@ -13,7 +13,7 @@ module Server (application) where
 import           Conduit                        (MonadTrans (lift), ResourceT)
 import           Control.Concurrent.STM
 import           Control.Monad                  (when)
-import           Control.Monad.Extra            (whenM, maybeM)
+import           Control.Monad.Extra            (maybeM, whenM)
 import           Control.Monad.IO.Class         (MonadIO (liftIO))
 import           Control.Monad.Logger.CallStack (NoLoggingT)
 import           Control.Monad.Reader           (forM)
@@ -58,27 +58,10 @@ import           Servant.Docs                   (DocCapture (..),
 import           Servant.Server                 (Handler)
 import           Servant.Swagger                (toSwagger)
 import           Web.PathPieces                 (PathPiece)
-import Text.ProtocolBuffers (defaultValue)
-import qualified Data.Sequence as Seq
-import Data.Time.Clock.POSIX (getPOSIXTime)
-import Data.Time.Clock.System (SystemTime(systemSeconds), getSystemTime)
-import Text.ProtocolBuffers.WireMessage (zzEncode64)
-
-import GTFS.Realtime.FeedMessage (FeedMessage(..))
-import GTFS.Realtime.FeedEntity ( FeedEntity(FeedEntity) )
-import GTFS.Realtime.FeedHeader (FeedHeader(FeedHeader))
-import GTFS.Realtime.FeedHeader.Incrementality (Incrementality(FULL_DATASET))
 
 import           API
 import           Persist
-import GTFS.Realtime.Alert (Alert(Alert))
-import GTFS.Realtime.Alert.SeverityLevel (SeverityLevel(WARNING))
-import GTFS.Realtime.Alert.Cause (Cause(CONSTRUCTION))
-import GTFS.Realtime.Alert.Effect (Effect(DETOUR))
-import GTFS.Realtime.TranslatedString (TranslatedString(TranslatedString))
-import GTFS.Realtime.TranslatedString.Translation (Translation(Translation))
-import GTFS.Realtime.TimeRange (TimeRange(TimeRange))
-import GTFS.Realtime.EntitySelector (EntitySelector(EntitySelector))
+import           Server.GTFSRT                  (gtfsRealtimeServer)
 
 application :: GTFS -> Pool SqlBackend -> IO Application
 application gtfs dbpool = do
@@ -94,7 +77,8 @@ doMigration pool = runSql pool $
 
 server :: GTFS -> Pool SqlBackend -> Server CompleteAPI
 server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> handleStations :<|> handleTimetable :<|> handleTrip
-  :<|> handleRegister :<|> handleTripPing :<|> handleDebugState :<|> gtfsRealtimeServer
+  :<|> handleRegister :<|> handleTripPing :<|> handleDebugState :<|> gtfsRealtimeServer gtfs dbpool
+  :<|> adminServer gtfs dbpool
   where handleStations = pure stations
         handleTimetable station maybeDay = do
           -- TODO: resolve "overlay" trips (perhaps just additional CalendarDates?)
@@ -125,47 +109,9 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> handleStations :<|> handleTime
            pure (M.fromList pairs)
         handleDebugAPI = pure $ toSwagger (Proxy @API)
 
-gtfsRealtimeServer :: Server GtfsRealtimeAPI
-gtfsRealtimeServer = handleServiceAlerts :<|> handleDummy :<|> handleDummy
-  where handleDummy = do
-          pure $ FeedEntity
-            "1234"
-            Nothing
-            Nothing
-            Nothing
-            Nothing
-            Nothing
-            defaultValue
-        handleServiceAlerts = do
-          now <- liftIO getSystemTime <&> systemSeconds
-          pure $ FeedMessage
-            (FeedHeader "2.0" (Just FULL_DATASET) (Just $ fromIntegral now) defaultValue)
-            (Seq.fromList
-             [FeedEntity
-              "0"
-              Nothing
-              Nothing
-              Nothing
-              (Just $ Alert
-               [TimeRange (Just $ fromIntegral (now - 1000)) Nothing defaultValue]
-               [EntitySelector Nothing (Just "Passau - Freyung") Nothing Nothing Nothing Nothing defaultValue]
-               (Just CONSTRUCTION)
-               (Just DETOUR)
-               (lang "de" "https://ilztalbahn.eu")
-               (lang "de" "Da liegt ein Baum auf der Strecke")
-               (lang "de" "Leider liegt ein Baum auf der Strecke. Solange fährt hier nix.")
-               Nothing
-               Nothing
-               (Just WARNING)
-               Nothing
-               Nothing
-               defaultValue
-              )
-              Nothing
-              defaultValue
-             ])
-            defaultValue
-        lang code msg = Just $ TranslatedString [Translation msg (Just code) defaultValue] defaultValue
+
+adminServer :: GTFS -> Pool SqlBackend -> Server AdminAPI
+adminServer = undefined
 
 
 -- TODO: proper debug logging for expired tokens
diff --git a/lib/Server/GTFSRT.hs b/lib/Server/GTFSRT.hs
new file mode 100644
index 0000000..7035ccf
--- /dev/null
+++ b/lib/Server/GTFSRT.hs
@@ -0,0 +1,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
+  }