From d5c7beb4507f5a0ba361464173447ed3521d9973 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sat, 2 Jul 2022 18:14:47 +0200
Subject: rudimentary admin api implementation

---
 lib/API.hs           |  7 ++++---
 lib/Persist.hs       |  9 ++++-----
 lib/Server.hs        | 19 +++++++++++++++++--
 lib/Server/GTFSRT.hs |  1 +
 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
-- 
cgit v1.2.3