aboutsummaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
authorstuebinm2022-07-02 18:14:47 +0200
committerstuebinm2022-07-02 18:14:47 +0200
commitd5c7beb4507f5a0ba361464173447ed3521d9973 (patch)
treef6eb32fc35053bc986fc37db5a125db800b8d8c0 /lib
parent84a620a47bd23d5d0f93ae6c7abe5d622005044d (diff)
rudimentary admin api implementation
Diffstat (limited to 'lib')
-rw-r--r--lib/API.hs7
-rw-r--r--lib/Persist.hs9
-rw-r--r--lib/Server.hs19
-rw-r--r--lib/Server/GTFSRT.hs1
4 files changed, 26 insertions, 10 deletions
diff --git a/lib/API.hs b/lib/API.hs
index 5afd041..845ad06 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -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