aboutsummaryrefslogtreecommitdiff
path: root/lib/Server
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Server')
-rw-r--r--lib/Server/ControlRoom.hs85
-rw-r--r--lib/Server/GTFS_RT.hs20
-rw-r--r--lib/Server/Util.hs12
3 files changed, 85 insertions, 32 deletions
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] }
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-19 13:45:41 +0000