controlroom: lots of pretty little knobs

(also some database schema changes, for good measure)

7 files changed, 185 insertions, 123 deletions

diff --git a/lib/API.hs b/lib/API.hs
index 99e96ae..9016524 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -1,15 +1,17 @@
 {-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE TypeOperators     #-}
 
 -- | 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, AdminAPI) where
+module API (API, CompleteAPI, GtfsRealtimeAPI, RegisterJson(..)) where
 
 import           Data.Map                    (Map)
 import           Data.Proxy                  (Proxy (..))
-import           Data.Swagger                (Swagger)
+import           Data.Swagger                (Swagger, ToSchema (..),
+                                              genericDeclareNamedSchema)
 import           Data.Swagger.ParamSchema    (ToParamSchema (..))
 import           Data.Text                   (Text)
 import           Data.Time                   (Day, UTCTime)
@@ -25,12 +27,22 @@ import           Servant.GTFS.Realtime       (Proto)
 import           Servant.Swagger             (HasSwagger (..))
 import           Web.Internal.FormUrlEncoded (Form)
 
+import           Data.Aeson                  (FromJSON (..), genericParseJSON)
+import           GHC.Generics                (Generic)
 import           GTFS
 import           GTFS.Realtime.FeedEntity
 import           GTFS.Realtime.FeedMessage   (FeedMessage)
 import           Persist
 import           Server.ControlRoom
 
+data RegisterJson = RegisterJson
+  { registerAgent :: Text }
+  deriving (Show, Generic)
+
+instance FromJSON RegisterJson where
+  parseJSON = genericParseJSON (aesonOptions "register")
+instance ToSchema RegisterJson where
+  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "station")
 
 -- | The server's API (as it is actually intended).
 type API = "stations" :> Get '[JSON] (Map StationID Station)
@@ -38,52 +50,31 @@ type API = "stations" :> Get '[JSON] (Map StationID Station)
   :<|> "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
+  :<|> "train" :> "register" :> Capture "Trip ID" TripID :> ReqBody '[JSON] RegisterJson :> Post '[JSON] Token
   -- TODO: perhaps a websocket instead?
-  :<|> "train" :> "ping" :> ReqBody '[JSON] TripPing :> Post '[JSON] NoContent
+  :<|> "train" :> "ping" :> ReqBody '[JSON] TrainPing :> Post '[JSON] NoContent
   :<|> "train" :> "ping" :> "ws" :> WebSocket
   -- debug things
-  :<|> "debug" :> "state" :> Get '[JSON] (Map Token [TripPing])
+  :<|> "debug" :> "pings" :> Get '[JSON] (Map Token [TrainPing])
+  :<|> "debug" :> "pings" :> Capture "Trip ID" TripID :> Capture "day" Day :> Get '[JSON] [TrainPing]
+  :<|> "debug" :> "register" :> Capture "Trip ID" TripID :> Capture "day" Day :> Post '[JSON] Token
   :<|> "gtfs" :> GtfsRealtimeAPI
-  -- TODO: this should be behind auth / OpenID or something
-  :<|> "admin" :> AdminAPI
 
 -- | The API used for publishing gtfs realtime updates
 type GtfsRealtimeAPI = "servicealerts" :> Get '[Proto] FeedMessage
   :<|> "tripupdates" :> Get '[Proto] FeedMessage
   :<|> "vehiclepositions" :> Get '[Proto] FeedMessage
 
--- | Admin API used for short-term timetable changes etc. ("leitstelle")
-type AdminAPI =
-  "trip" :> "announce" :> ReqBody '[JSON] Announcement :> Post '[JSON] UUID
-  :<|> "trip" :> "announce" :> "delete" :> Capture "Announcement ID" UUID :> Post '[JSON] NoContent
-  :<|> "trip" :> "date" :> "add" :> Capture "Trip ID" TripID :> Capture "day" Day :> Post '[JSON] NoContent
-  :<|> "trip" :> "date" :> "cancel" :> Capture "Trip ID" TripID :> Capture "day" Day :> Post '[JSON] NoContent
--- 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] NoContent
-
 
 -- | The server's API with an additional debug route for accessing the specification
 -- itself. Split from API to prevent the API documenting the format in which it is
 -- documented, which would be silly and way to verbose.
-type CompleteAPI = "debug" :> "openapi" :> Get '[JSON] Swagger
-  :<|> API
-  :<|> "cr" :> Raw
+type CompleteAPI =
+  "api" :> "openapi" :> Get '[JSON] Swagger
+  :<|> "api" :> API
+  :<|> Raw -- hook for yesod frontend
 
 
 -- TODO write something useful here! (and if it's just "hey this is some websocket thingie")
 instance HasSwagger WebSocket where
   toSwagger _ = toSwagger (Proxy @(Post '[JSON] NoContent))
-{-
-TODO:
-there should be a basic API allowing the questions:
- - what are the next trips leaving from $station? (or $geolocation?)
- - all stops of a given tripID
-
-then the "ingress" API:
- - train ping (location, estimated delay, etc.)
- - cancel trip
- - add trip?
-
--}
diff --git a/lib/GTFS.hs b/lib/GTFS.hs
index 9259649..bfb1c49 100644
--- a/lib/GTFS.hs
+++ b/lib/GTFS.hs
@@ -51,6 +51,7 @@ import           Web.Internal.FormUrlEncoded    (FromForm (..))
 import           Web.Internal.HttpApiData       (FromHttpApiData (..))
 -- import Data.Aeson.Generic (Options(fieldLabelModifier), deriveJSON, defaultOptions)
 import           Control.Lens
+import           Control.Monad.IO.Class         (MonadIO (liftIO))
 import           Data.Char                      (toLower)
 import           Data.Foldable                  (Foldable (fold))
 import           Data.Map                       (Map)
@@ -459,3 +460,12 @@ tripsAtStation GTFS{..} at = fmap stopTrip stops
 
 tripsOnDay :: GTFS -> Day -> Map TripID (Trip Deep Deep)
 tripsOnDay gtfs today = foldMap (tripsOfService gtfs) (servicesOnDay gtfs today)
+
+runsOnDay :: GTFS -> TripID -> Day -> Bool
+runsOnDay gtfs trip day = not . null . M.filter same $ tripsOnDay gtfs day
+  where same Trip{..} = tripTripID == trip
+
+runsToday :: MonadIO m => GTFS -> TripID -> m Bool
+runsToday gtfs trip = do
+  today <- liftIO getCurrentTime <&> utctDay
+  pure (runsOnDay gtfs trip today)
diff --git a/lib/Persist.hs b/lib/Persist.hs
index 611da9e..39cdca1 100644
--- a/lib/Persist.hs
+++ b/lib/Persist.hs
@@ -58,32 +58,51 @@ instance ToSchema Token where
 instance ToParamSchema Token where
   toParamSchema _ = toParamSchema (Proxy @String)
 
-data AmendmentStatus = Cancelled | Added
+data AmendmentStatus = Cancelled | Added | PartiallyCancelled Int Int
   deriving (ToJSON, FromJSON, Generic, Show, Read, Eq)
 derivePersistField "AmendmentStatus"
-instance FromHttpApiData AmendmentStatus where
-  parseUrlPiece "Cancelled" = Right Cancelled
-  parseUrlPiece "Added"     = Right Added
-  parseUrlPiece other       = Left ("unknown AmendmentStatus: "<>other)
+-- instance FromHttpApiData AmendmentStatus where
+--   parseUrlPiece "Cancelled" = Right Cancelled
+--   parseUrlPiece "Added"     = Right Added
+--   parseUrlPiece other       = Left ("unknown AmendmentStatus: "<>other)
 
 share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
 -- | tokens which have been issued
-RunningTrip sql=tt_tracker_token
+Running sql=tt_tracker_token
   Id Token default=uuid_generate_v4()
   expires UTCTime
   blocked Bool
-  tripNumber Text
+  trip Text
+  day Day
   vehicle Text Maybe
+  agent Text
   deriving Eq Show Generic
 
-TripPing json sql=tt_trip_ping
-  token RunningTripId
+-- raw frames as received from OBUs
+TrainPing json sql=tt_trip_ping
+  token RunningId
   lat Double
   long Double
-  delay Double
   timestamp UTCTime
   deriving Show Generic Eq ToSchema
 
+-- status of a train somewhen in time (may be in the future),
+-- inferred from trainpings / entered via controlRoom
+TrainStatus sql=tt_train_status
+  timestamp UTCTime
+  trip TripID
+  day Day
+  when UTCTime
+  deriving Show Generic Eq ToSchema
+
+TripAnchor json sql=tt_trip_anchor
+  trip TripID
+  day Day
+  timestamp UTCTime
+  delay Int Maybe
+  msg Text Maybe
+  deriving Show Generic Eq ToSchema
+
 -- TODO: multi-language support?
 Announcement json sql=tt_announcements
   Id UUID default=uuid_generate_v4()
@@ -102,16 +121,9 @@ ScheduleAmendment json sql=tt_schedule_amendement
   status AmendmentStatus
   -- only one special rule per TripID and Day (else incoherent)
   TripAndDay trip day
-
--- TODO: possible to have regular trips moved in time without changing TripID?
-ExtraordinaryTrip sql=tt_extra_trip
-  trip TripID
-  day Text
-  stops (Vector Text)
-  stopTimes (Vector TimeOfDay)
 |]
 
-instance ToSchema RunningTripId where
+instance ToSchema RunningId where
   declareNamedSchema _ = declareNamedSchema (Proxy @UUID)
 
 runSql :: MonadIO m => Pool SqlBackend -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> m a
diff --git a/lib/Server.hs b/lib/Server.hs
index f7ee81b..75617bd 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -11,8 +11,8 @@
 
 -- Implementation of the API. This module is the main point of the program.
 module Server (application) where
-import           Control.Monad               (forever, void, when)
-import           Control.Monad.Extra         (maybeM, whenM)
+import           Control.Monad               (forever, unless, void, when)
+import           Control.Monad.Extra         (maybeM, unlessM, whenM)
 import           Control.Monad.IO.Class      (MonadIO (liftIO))
 import           Control.Monad.Logger        (logWarnN)
 import           Control.Monad.Reader        (forM)
@@ -35,8 +35,9 @@ import           Database.Persist
 import           Database.Persist.Postgresql (SqlBackend, runMigration)
 import           Fmt                         ((+|), (|+))
 import qualified Network.WebSockets          as WS
-import           Servant                     (Application, err401, err404,
-                                              serve, throwError)
+import           Servant                     (Application,
+                                              ServerError (errBody), err401,
+                                              err404, serve, throwError)
 import           Servant.API                 (NoContent (..), (:<|>) (..))
 import           Servant.Server              (Handler, hoistServer)
 import           Servant.Swagger             (toSwagger)
@@ -46,7 +47,8 @@ import           GTFS
 import           Persist
 import           Server.ControlRoom
 import           Server.GTFS_RT              (gtfsRealtimeServer)
-import           Server.Util                 (Service, ServiceM, runService)
+import           Server.Util                 (Service, ServiceM, runService,
+                                              sendErrorMsg)
 import           Yesod                       (toWaiAppPlain)
 
 import           System.IO.Unsafe
@@ -64,11 +66,12 @@ doMigration pool = runSql pool $
   runMigration migrateAll
 
 server :: GTFS -> Pool SqlBackend -> Service CompleteAPI
-server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> (handleStations :<|> handleTimetable :<|> handleTrip
-  :<|> handleRegister :<|> handleTripPing :<|> handleWS :<|> handleDebugState :<|>
-  gtfsRealtimeServer gtfs dbpool
-  :<|> adminServer gtfs dbpool)
-  :<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom "http://localhost:4000/cr" gtfs dbpool)))
+server gtfs@GTFS{..} dbpool = handleDebugAPI
+  :<|> (handleStations :<|> handleTimetable :<|> handleTrip
+        :<|> handleRegister :<|> handleTripPing :<|> handleWS
+        :<|> handleDebugState :<|> handleDebugTrain :<|> handleDebugRegister
+        :<|> gtfsRealtimeServer gtfs dbpool)
+  :<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom gtfs dbpool)))
   where handleStations = pure stations
         handleTimetable station maybeDay = do
           -- TODO: resolve "overlay" trips (perhaps just additional CalendarDates?)
@@ -80,13 +83,19 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> (handleStations :<|> handleTim
         handleTrip trip = case M.lookup trip trips of
           Just res -> pure res
           Nothing  -> throwError err404
-        handleRegister tripID = do
-          -- TODO registration may carry extra information!
+        handleRegister tripID RegisterJson{..} = do
+          today <- liftIO getCurrentTime <&> utctDay
+          when (not $ runsOnDay gtfs tripID today)
+            $ sendErrorMsg "this trip does not run today."
           expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod
-          RunningTripKey token <- runSql dbpool $ insert (RunningTrip expires False tripID Nothing)
+          RunningKey token <- runSql dbpool $ insert (Running expires False tripID today Nothing registerAgent)
+          pure token
+        handleDebugRegister tripID day = do
+          expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod
+          RunningKey token <- runSql dbpool $ insert (Running expires False tripID day Nothing "debug key")
           pure token
         handleTripPing ping = do
-          lift $ checkTokenValid dbpool (coerce $ tripPingToken ping)
+          lift $ checkTokenValid dbpool (coerce $ trainPingToken ping)
           -- TODO: are these always inserted in order?
           runSql dbpool $ insert ping
           pure NoContent
@@ -100,47 +109,34 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> (handleStations :<|> handleTim
                 logWarnN ("stray websocket message: "+|show msg|+" (could not decode: "+|err|+")")
                 liftIO $ WS.sendClose conn (C8.pack err)
               Right ping -> do
-                lift $ checkTokenValid dbpool (coerce $ tripPingToken ping)
+                lift $ checkTokenValid dbpool (coerce $ trainPingToken ping)
                 void $ runSql dbpool $ insert ping
         handleDebugState = do
           now <- liftIO getCurrentTime
           runSql dbpool $ do
-           running <- selectList [RunningTripBlocked ==. False, RunningTripExpires >=. now] []
-           pairs <- forM running $ \(Entity token@(RunningTripKey uuid) _) -> do
-             entities <- selectList [TripPingToken ==. token] []
+           running <- selectList [RunningBlocked ==. False, RunningExpires >=. now] []
+           pairs <- forM running $ \(Entity token@(RunningKey uuid) _) -> do
+             entities <- selectList [TrainPingToken ==. token] []
              pure (uuid, fmap entityVal entities)
            pure (M.fromList pairs)
+        handleDebugTrain tripId day = do
+          unless (runsOnDay gtfs tripId day)
+            $ sendErrorMsg ("this trip does not run on "+|day|+".")
+          runSql dbpool $ do
+            tokens <- selectList [RunningTrip ==. tripId, RunningDay ==. day] []
+            pings <- forM tokens $ \(Entity token _) -> do
+              selectList [TrainPingToken ==. token] [] <&> fmap entityVal
+            pure (concat pings)
         handleDebugAPI = pure $ toSwagger (Proxy @API)
 
 
-adminServer :: GTFS -> Pool SqlBackend -> Service AdminAPI
-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)
-          pure NoContent
-        modTripDate one two tripId day = runSql dbpool $ do
-          getBy (TripAndDay tripId day) >>= \case
-            Just (Entity key (ScheduleAmendment _ _ status)) -> do
-              when (status == two) $ delete key
-              pure NoContent
-            Nothing -> do
-              insert (ScheduleAmendment tripId day one)
-              pure NoContent
-        extraTrip = error "unimplemented!"
-
-
 -- TODO: proper debug logging for expired tokens
 checkTokenValid :: Pool SqlBackend -> Token -> Handler ()
 checkTokenValid dbpool token = do
   trip <- try $ runSql dbpool $ get (coerce token)
-  when (runningTripBlocked trip)
+  when (runningBlocked trip)
     $ throwError err401
-  whenM (hasExpired (runningTripExpires trip))
+  whenM (hasExpired (runningExpires trip))
     $ throwError err401
   where try m = m >>= \case
           Just a  -> pure a
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs
index 9ebea42..4ef3784 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/ControlRoom.hs
@@ -28,7 +28,7 @@ import qualified Data.Map                 as M
 import           Data.Pool                (Pool)
 import           Data.Text                (Text)
 import qualified Data.Text                as T
-import           Data.Time                (getCurrentTime, utctDay)
+import           Data.Time                (UTCTime, getCurrentTime, utctDay)
 import           Data.Time.Calendar       (Day)
 import           Data.Time.Format.ISO8601 (iso8601Show)
 import           Data.UUID                (UUID)
@@ -40,13 +40,9 @@ import           Database.Persist.Sql     (PersistFieldSql, SqlBackend,
                                            runSqlPool)
 import           Fmt                      ((+|), (|+))
 import           GHC.Generics             (Generic)
-import           Persist                  (AmendmentStatus, Announcement (..),
-                                           EntityField (..), Key (..),
-                                           ScheduleAmendment (ScheduleAmendment),
-                                           runSql)
 import           Server.Util              (Service)
 import           Text.Blaze.Html          (ToMarkup (..))
-import           Text.Blaze.Internal (MarkupM(Empty))
+import           Text.Blaze.Internal      (MarkupM (Empty))
 import           Text.ProtocolBuffers     (Default (defaultValue))
 import           Text.Read                (readMaybe)
 import           Text.Shakespeare.Text
@@ -54,12 +50,12 @@ import           Yesod
 import           Yesod.Form
 
 import           GTFS
+import           Persist
 
 
 data ControlRoom = ControlRoom
-  { getBaseurl :: Text
-  , getGtfs    :: GTFS
-  , getPool    :: Pool SqlBackend
+  { getGtfs :: GTFS
+  , getPool :: Pool SqlBackend
   }
 
 mkMessage "ControlRoom" "messages" "en"
@@ -70,17 +66,16 @@ mkYesod "ControlRoom" [parseRoutes|
 /train/id/#TripID/#Day TrainViewR GET
 /train/announce/#TripID/#Day AnnounceR POST
 /train/del-announce/#UUID DelAnnounceR GET
+/token/block/#Token TokenBlock GET
 /trips TripsViewR GET
 /trip/#TripID TripViewR GET
 |]
 
 emptyMarkup :: MarkupM a -> Bool
 emptyMarkup (Empty _) = True
-emptyMarkup _ = False
+emptyMarkup _         = False
 
 instance Yesod ControlRoom where
-  approot = ApprootMaster (\cr -> getBaseurl cr)
-
   defaultLayout w = do
       PageContent{..} <- widgetToPageContent w
       msgs <- getMessages
@@ -125,6 +120,9 @@ instance Yesod ControlRoom where
              input {
                grid-column: 2;
              }
+             .blocked {
+               background-color: red;
+             }
           <body>
             $forall (status, msg) <- msgs
               <p class="message #{status}">#{msg}
@@ -169,12 +167,28 @@ getTrainViewR trip day = do
     Nothing -> notFound
     Just res@Trip{..} -> do
       anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] []
+      tokens <- runDB $ selectList [ RunningTrip ==. trip, RunningDay ==. day ] []
+      lastPing <- runDB $ selectFirst [ TrainPingToken <-. (fmap entityKey tokens) ] [Desc TrainPingTimestamp]
       defaultLayout $ do
         mr <- getMessageRender
         setTitle (toHtml (""+|mr MsgTrip|+" "+|tripTripID|+" "+|mr Msgon|+" "+|day|+"" :: Text))
         [whamlet|
 <h1>_{MsgTrip} <a href="@{TripViewR tripTripID}">#{tripTripID}</a> _{Msgon} <a href="@?{(TrainsR, [("day", T.pack (iso8601Show day))])}">#{day}</a>
 <section>
+  <h2>_{MsgLive}
+  <p><strong>_{MsgLastPing}: </strong>
+    $maybe Entity _ TrainPing{..} <- lastPing
+      _{MsgTrainPing trainPingLat trainPingLong trainPingTimestamp}
+      (<a href="/api/debug/pings/#{trip}/#{day}">_{Msgraw}</a>)
+    $nothing
+      <em>(_{MsgNoTrainPing})
+  <p><strong>Estimated Delay</strong>: Todo!
+<section>
+  <h2>_{MsgStops}
+  <ol>
+    $forall Stop{..} <- tripStops
+      <li> #{stopArrival} #{stationName stopStation}
+<section>
   <h2>_{MsgAnnouncements}
   <ul>
     $forall Entity (AnnouncementKey uuid) Announcement{..} <- anns
@@ -186,13 +200,18 @@ getTrainViewR trip day = do
     ^{widget}
     <button>Submit
 <section>
-  <h2>_{MsgStops}
-  <ol>
-    $forall Stop{..} <- tripStops
-      <li> #{stopArrival} #{stationName stopStation}
-<section>
-  <h2>Vehicle Position
-  <div> Todo!
+  <h2>_{MsgTokens}
+  <table>
+    <tr><th style="width: 20%">_{MsgAgent}</th><th style="width: 50%">_{MsgToken}</th><th>_{MsgExpires}</th><th>_{MsgStatus}</th>
+    $forall Entity (RunningKey key) Running{..} <- tokens
+      <tr :runningBlocked:.blocked>
+        <td title="#{runningAgent}">#{runningAgent}
+        <td title="#{key}">#{key}
+        <td title="#{runningExpires}">#{runningExpires}
+        $if runningBlocked
+          <td title="_{MsgUnblockToken}"><a href="@?{(TokenBlock key, [("unblock", "true")])}">_{MsgUnblockToken}</a>
+        $else
+          <td title="_{MsgBlockToken}"><a href="@{TokenBlock key}">_{MsgBlockToken}</a>
 |]
 
 
@@ -255,6 +274,19 @@ getDelAnnounceR uuid = do
     Just Announcement{..} ->
       redirect (TrainViewR announcementTrip announcementDay)
 
+getTokenBlock :: Token -> Handler Html
+getTokenBlock token = do
+  YesodRequest{..} <- getRequest
+  let blocked = lookup "unblock" reqGetParams /= Just "true"
+  maybe <- runDB $ do
+    update (RunningKey token) [ RunningBlocked =. blocked ]
+    get (RunningKey token)
+  case maybe of
+    Just r@Running{..} -> do
+      liftIO $ print r
+      redirect (TrainViewR runningTrip runningDay)
+    Nothing -> notFound
+
 
 announceForm :: Day -> TripID -> Html -> MForm Handler (FormResult Announcement, Widget)
 announceForm day tripId = renderDivs $ Announcement
@@ -274,3 +306,18 @@ instance ToMarkup Time where
 
 instance ToMarkup Day where
   toMarkup day = toMarkup (iso8601Show day)
+
+instance ToMessage UTCTime where
+  toMessage = formatW3
+
+instance ToMessage Token where
+  toMessage (Token uuid) = UUID.toText uuid
+
+instance ToMarkup UTCTime where
+  toMarkup = toMarkup . formatW3
+
+instance ToMarkup Token where
+  toMarkup (Token uuid) = toMarkup (UUID.toText uuid)
+
+instance ToMessage Double where
+  toMessage = T.pack . show
diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs
index d771736..dfdd1eb 100644
--- a/lib/Server/GTFS_RT.hs
+++ b/lib/Server/GTFS_RT.hs
@@ -51,8 +51,8 @@ import           GTFS.Realtime.VehiclePosition              as VP (VehiclePositi
 import           Persist                                    (Announcement (..),
                                                              EntityField (..),
                                                              Key (..),
-                                                             RunningTrip (..),
-                                                             TripPing (..),
+                                                             Running (..),
+                                                             TrainPing (..),
                                                              runSql)
 import           Servant.API                                ((:<|>) (..))
 import           Text.ProtocolBuffers                       (Utf8 (Utf8),
@@ -115,15 +115,15 @@ gtfsRealtimeServer gtfs dbpool = handleServiceAlerts :<|> handleTripUpdates :<|>
           -- TODO: how to propagate delay values to next stops?
           pure undefined
         handleVehiclePositions = runSql dbpool $ do
-          (running :: [Entity RunningTrip]) <- selectList [] []
+          (running :: [Entity Running]) <- selectList [] []
           pings <- forM running $ \(Entity key entity) -> do
-            selectFirst [TripPingToken ==. key] [] <&> fmap (, entity)
+            selectFirst [TrainPingToken ==. key] [] <&> fmap (, entity)
           dFeedMessage $ Seq.fromList $ mkPosition <$> catMaybes pings
-          where mkPosition (Entity (TripPingKey key) TripPing{..}, RunningTrip{..}) =
+          where mkPosition (Entity (TrainPingKey key) TrainPing{..}, Running{..}) =
                   (dFeedEntity (toUtf8 . T.pack . show $ key))
                   { FE.vehicle = Just $ VehiclePosition
-                    { trip = Just (dTripDescriptor runningTripTripNumber Nothing)
-                    , VP.vehicle = case runningTripVehicle of
+                    { trip = Just (dTripDescriptor runningTrip Nothing)
+                    , VP.vehicle = case runningVehicle of
                         Nothing -> Nothing
                         Just trainset -> Just $ VehicleDescriptor
                              { VD.id = Nothing
@@ -132,8 +132,8 @@ gtfsRealtimeServer gtfs dbpool = handleServiceAlerts :<|> handleTripUpdates :<|>
                              , VD.ext'field = defaultValue
                              }
                     , position = Just $ Position
-                      { latitude = double2Float tripPingLat
-                      , longitude = double2Float tripPingLong
+                      { latitude = double2Float trainPingLat
+                      , longitude = double2Float trainPingLong
                       , odometer = Nothing
                       , speed = Nothing
                       , bearing = Nothing
@@ -143,7 +143,7 @@ gtfsRealtimeServer gtfs dbpool = handleServiceAlerts :<|> handleTripUpdates :<|>
                     , current_stop_sequence = Nothing
                     , stop_id = Nothing
                     , current_status = Nothing
-                    , timestamp = Just (toStupidTime tripPingTimestamp)
+                    , timestamp = Just (toStupidTime trainPingTimestamp)
                     , congestion_level = Nothing
                     , occupancy_status = Nothing
                     , occupancy_percentage = Nothing
diff --git a/lib/Server/Util.hs b/lib/Server/Util.hs
index a7a358e..5bfba52 100644
--- a/lib/Server/Util.hs
+++ b/lib/Server/Util.hs
@@ -1,15 +1,21 @@
 {-# LANGUAGE FlexibleContexts #-}
 
 -- | mostly the monad the service runs in
-module Server.Util (Service, ServiceM, runService) where
+module Server.Util (Service, ServiceM, runService, sendErrorMsg) where
 
 import           Control.Monad.Logger (LoggingT, runStderrLoggingT)
+import qualified Data.Aeson           as A
 import           Data.ByteString      (ByteString)
-import           Servant              (Handler, ServerError, ServerT, err302,
-                                       errHeaders, throwError)
+import           Data.Text            (Text)
+import           Servant              (Handler, ServerError, ServerT, err404,
+                                       errBody, errHeaders, throwError)
 
 type ServiceM  = LoggingT Handler
 type Service api = ServerT api ServiceM
 
 runService :: ServiceM a -> Handler a
 runService = runStderrLoggingT
+
+sendErrorMsg :: Text -> ServiceM a
+sendErrorMsg msg = throwError err404
+  { errBody = A.encode $ A.object ["error" A..= (404 :: Int), "msg" A..= msg] }