diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/API.hs | 7 | ||||
| -rw-r--r-- | lib/Persist.hs | 9 | ||||
| -rw-r--r-- | lib/Server.hs | 19 | ||||
| -rw-r--r-- | lib/Server/GTFSRT.hs | 1 |
4 files changed, 26 insertions, 10 deletions
@@ -40,6 +40,7 @@ type API = "stations" :> Get '[JSON] (Map StationID Station) -- debug things :<|> "debug" :> "state" :> Get '[JSON] (Map Token [TripPing]) :<|> "gtfs" :> GtfsRealtimeAPI + -- TODO: this should be behind auth / OpenID or something :<|> "admin" :> AdminAPI -- | The API used for publishing gtfs realtime updates @@ -49,10 +50,10 @@ type GtfsRealtimeAPI = "servicealerts" :> 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" :> ReqBody '[JSON] Announcement :> 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] () + :<|> "trip" :> "date" :> "add" :> Capture "Trip ID" TripID :> Capture "day" Day :> Post '[JSON] () + :<|> "trip" :> "date" :> "cancel" :> Capture "Trip ID" TripID :> Capture "day" Day :> 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] () diff --git a/lib/Persist.hs b/lib/Persist.hs index e73b74f..c44ae3b 100644 --- a/lib/Persist.hs +++ b/lib/Persist.hs @@ -77,10 +77,10 @@ TripPing json sql=tt_trip_ping long Double delay Double timestamp UTCTime - deriving Show Generic Eq + deriving Show Generic Eq ToSchema -- TODO: multi-language support? -Announcement sql=tt_announcements +Announcement json sql=tt_announcements Id UUID default=uuid_generate_v4() trip TripID message Text @@ -88,11 +88,12 @@ Announcement sql=tt_announcements day Day url Text Maybe announcedAt UTCTime Maybe + deriving Generic ToSchema -- | this table works as calendar_dates.txt in GTFS ScheduleAmendment json sql=tt_schedule_amendement trip TripID - day Text + day Day status AmendmentStatus -- only one special rule per TripID and Day (else incoherent) TripAndDay trip day @@ -107,8 +108,6 @@ ExtraordinaryTrip sql=tt_extra_trip instance ToSchema RunningTripId where declareNamedSchema _ = declareNamedSchema (Proxy @UUID) -instance ToSchema TripPing where - declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "ping") runSql :: MonadIO m => Pool SqlBackend -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> m a runSql pool = liftIO . flip runSqlPersistMPool pool diff --git a/lib/Server.hs b/lib/Server.hs index 5ece540..2b86b6e 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -29,7 +29,7 @@ import Data.Map (Map) import qualified Data.Map as M import Data.Pool (Pool) import Data.Proxy (Proxy (Proxy)) -import Data.Swagger hiding (get) +import Data.Swagger hiding (get, delete) import Data.Text (Text) import Data.Time (NominalDiffTime, UTCTime (utctDay), addUTCTime, @@ -112,7 +112,22 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> handleStations :<|> handleTime adminServer :: GTFS -> Pool SqlBackend -> Server AdminAPI -adminServer = undefined +adminServer gtfs dbpool = + addAnnounce :<|> delAnnounce :<|> modTripDate Added Cancelled + :<|> modTripDate Cancelled Added :<|> extraTrip + where addAnnounce ann@Announcement{..} = runSql dbpool $ do + AnnouncementKey uuid <- insert ann + pure uuid + delAnnounce uuid = runSql dbpool $ do + delete (AnnouncementKey uuid) + modTripDate one two tripId day = runSql dbpool $ do + getBy (TripAndDay tripId day) >>= \case + Just (Entity key (ScheduleAmendment _ _ status)) -> do + when (status == two) $ delete key + Nothing -> do + insert (ScheduleAmendment tripId day one) + pure () + extraTrip = error "unimplemented!" -- TODO: proper debug logging for expired tokens diff --git a/lib/Server/GTFSRT.hs b/lib/Server/GTFSRT.hs index 0a654c6..bd285ff 100644 --- a/lib/Server/GTFSRT.hs +++ b/lib/Server/GTFSRT.hs @@ -144,6 +144,7 @@ gtfsRealtimeServer gtfs dbpool = handleServiceAlerts :<|> handleTripUpdates :<|> , bearing = Nothing , POS.ext'field = defaultValue } + -- TODO: at least one of these should probably be given , current_stop_sequence = Nothing , stop_id = Nothing , current_status = Nothing |