diff options
Diffstat (limited to '')
-rw-r--r-- | lib/Server.hs | 91 | ||||
-rw-r--r-- | lib/Server/ControlRoom.hs | 224 | ||||
-rw-r--r-- | lib/Server/GTFS_RT.hs | 49 |
3 files changed, 231 insertions, 133 deletions
diff --git a/lib/Server.hs b/lib/Server.hs index 016707b..c6d2d94 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RecordWildCards #-} -- Implementation of the API. This module is the main point of the program. @@ -16,8 +17,8 @@ import Control.Monad.Catch (handle) import Control.Monad.Extra (ifM, maybeM, unlessM, whenJust, whenM) import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Logger (LoggingT, logWarnN) -import Control.Monad.Reader (forM) +import Control.Monad.Logger (LoggingT, NoLoggingT, logWarnN) +import Control.Monad.Reader (ReaderT, forM) import Control.Monad.Trans (lift) import Data.Aeson ((.=)) import qualified Data.Aeson as A @@ -61,9 +62,11 @@ import Extrapolation (Extrapolator (..), LinearExtrapolator (..)) import System.IO.Unsafe +import Conduit (ResourceT) import Config (ServerConfig (serverConfigAssets)) import Data.ByteString (ByteString) import Data.ByteString.Lazy (toStrict) +import Data.UUID (UUID) import Prometheus import Prometheus.Metric.GHC @@ -83,7 +86,7 @@ doMigration pool = runSql pool $ -- returns an empty list runMigration migrateAll -server :: GTFS -> Metrics -> TVar (M.Map TripID [TQueue (Maybe TrainPing)]) -> Pool SqlBackend -> ServerConfig -> Service CompleteAPI +server :: GTFS -> Metrics -> TVar (M.Map UUID [TQueue (Maybe TrainPing)]) -> Pool SqlBackend -> ServerConfig -> Service CompleteAPI server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI :<|> (handleStations :<|> handleTimetable :<|> handleTimetableStops :<|> handleTrip :<|> handleRegister :<|> handleTrainPing (throwError err401) :<|> handleWS @@ -101,7 +104,7 @@ server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI pure . A.toJSON . fmap mkJson . M.elems $ tripsOnDay gtfs day where mkJson :: Trip Deep Deep -> A.Value mkJson Trip {..} = A.object - [ "trip" .= tripTripID + [ "trip" .= tripTripId , "sequencelength" .= (stopSequence . V.last) tripStops , "stops" .= fmap (\Stop{..} -> A.object [ "departure" .= toUTC stopDeparture tzseries day @@ -114,34 +117,35 @@ server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI handleTrip trip = case M.lookup trip trips of Just res -> pure res Nothing -> throwError err404 - handleRegister tripID RegisterJson{..} = do + handleRegister (ticketId :: UUID) RegisterJson{..} = do today <- liftIO getCurrentTime <&> utctDay - unless (runsOnDay gtfs tripID today) - $ sendErrorMsg "this trip does not run today." expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod - RunningKey token <- runSql dbpool $ insert (Running expires False tripID today Nothing registerAgent) - pure token - handleDebugRegister tripID day = do + runSql dbpool $ do + TrackerKey tracker <- insert (Tracker expires False registerAgent) + insert (TrackerTicket (TicketKey ticketId) (TrackerKey tracker)) + pure tracker + handleDebugRegister (ticketId :: UUID) = do expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod - RunningKey token <- runSql dbpool $ insert (Running expires False tripID day Nothing "debug key") - pure token - handleTrainPing onError ping = isTokenValid dbpool (coerce $ trainPingToken ping) >>= \case + runSql dbpool $ do + TrackerKey tracker <- insert (Tracker expires False "debug key") + insert (TrackerTicket (TicketKey ticketId) (TrackerKey tracker)) + pure tracker + handleTrainPing onError ping@TrainPing{..} = isTokenValid dbpool trainPingToken trainPingTicket + >>= \case Nothing -> do onError pure Nothing - Just running@Running{..} -> do - let anchor = extrapolateAnchorFromPing LinearExtrapolator gtfs running ping + Just (tracker@Tracker{..}, ticket@Ticket{..}) -> do + let anchor = extrapolateAnchorFromPing LinearExtrapolator gtfs ticket ping -- TODO: are these always inserted in order? runSql dbpool $ do insert ping - last <- selectFirst - [TrainAnchorTrip ==. runningTrip, TrainAnchorDay ==. runningDay] - [Desc TrainAnchorWhen] + last <- selectFirst [TrainAnchorTicket ==. trainPingTicket] [Desc TrainAnchorWhen] -- only insert new estimates if they've actually changed anything when (fmap (trainAnchorDelay . entityVal) last /= Just (trainAnchorDelay anchor)) $ void $ insert anchor queues <- liftIO $ atomically $ do - queues <- readTVar subscribers <&> M.lookup runningTrip + queues <- readTVar subscribers <&> M.lookup (coerce trainPingTicket) whenJust queues $ mapM_ (\q -> writeTQueue q (Just ping)) pure queues @@ -162,18 +166,18 @@ server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI liftIO $ handleTrainPing (WS.sendClose conn ("" :: ByteString)) ping >>= \case Just anchor -> WS.sendTextData conn (A.encode anchor) Nothing -> pure () - handleSubscribe tripId day conn = liftIO $ WS.withPingThread conn 30 (pure ()) $ do + handleSubscribe (ticketId :: UUID) conn = liftIO $ WS.withPingThread conn 30 (pure ()) $ do queue <- atomically $ do queue <- newTQueue qs <- readTVar subscribers writeTVar subscribers - $ M.insertWith (<>) tripId [queue] qs + $ M.insertWith (<>) ticketId [queue] qs pure queue -- send most recent ping, if any (so we won't have to wait for movement) lastPing <- runSql dbpool $ do - tokens <- selectList [RunningDay ==. day, RunningTrip ==. tripId] [] + trackers <- getTicketTrackers ticketId <&> fmap entityKey - selectFirst [TrainPingToken <-. tokens] [Desc TrainPingTimestamp] + selectFirst [TrainPingToken <-. trackers] [Desc TrainPingTimestamp] <&> fmap entityVal whenJust lastPing $ \ping -> WS.sendTextData conn (A.encode lastPing) @@ -187,34 +191,39 @@ server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI where removeSubscriber queue = atomically $ do qs <- readTVar subscribers writeTVar subscribers - $ M.adjust (filter (/= queue)) tripId qs + $ M.adjust (filter (/= queue)) ticketId qs handleDebugState = do now <- liftIO getCurrentTime runSql dbpool $ do - running <- selectList [RunningBlocked ==. False, RunningExpires >=. now] [] - pairs <- forM running $ \(Entity token@(RunningKey uuid) _) -> do + tracker <- selectList [TrackerBlocked ==. False, TrackerExpires >=. now] [] + pairs <- forM tracker $ \(Entity token@(TrackerKey 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|+".") + handleDebugTrain ticketId = do runSql dbpool $ do - tokens <- selectList [RunningTrip ==. tripId, RunningDay ==. day] [] - pings <- forM tokens $ \(Entity token _) -> do + trackers <- getTicketTrackers ticketId + pings <- forM trackers $ \(Entity token _) -> do selectList [TrainPingToken ==. token] [] <&> fmap entityVal pure (concat pings) handleDebugAPI = pure $ toSwagger (Proxy @API) metrics = exportMetricsAsText <&> (decodeUtf8 . toStrict) +getTicketTrackers :: UUID -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) [Entity Tracker] +getTicketTrackers ticketId = do + joins <- selectList [TrackerTicketTicket ==. TicketKey ticketId] [] + <&> fmap (trackerTicketTracker . entityVal) + selectList [TrackerId <-. joins] [] + -- TODO: proper debug logging for expired tokens -isTokenValid :: MonadIO m => Pool SqlBackend -> Token -> m (Maybe Running) -isTokenValid dbpool token = runSql dbpool $ get (coerce token) >>= \case - Just trip | not (runningBlocked trip) -> do - ifM (hasExpired (runningExpires trip)) +isTokenValid :: MonadIO m => Pool SqlBackend -> TrackerId -> TicketId -> m (Maybe (Tracker, Ticket)) +isTokenValid dbpool token ticketId = runSql dbpool $ get token >>= \case + Just tracker | not (trackerBlocked tracker) -> do + ifM (hasExpired (trackerExpires tracker)) (pure Nothing) - (pure (Just trip)) + $ runSql dbpool $ get ticketId + <&> (\case { Nothing -> Nothing; Just ticket -> Just (tracker, ticket) }) _ -> pure Nothing hasExpired :: MonadIO m => UTCTime -> m Bool diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs index 773468a..4fb5ba8 100644 --- a/lib/Server/ControlRoom.hs +++ b/lib/Server/ControlRoom.hs @@ -1,16 +1,17 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Server.ControlRoom (ControlRoom(..)) where -import Control.Monad (forM_, join) +import Config (ServerConfig (..), UffdConfig (..)) +import Control.Monad (forM, forM_, join) import Control.Monad.Extra (maybeM) import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Data.Aeson as A @@ -21,6 +22,7 @@ import Data.List (lookup) import Data.List.NonEmpty (nonEmpty) import Data.Map (Map) import qualified Data.Map as M +import Data.Maybe (catMaybes, fromJust) import Data.Pool (Pool) import Data.Text (Text) import qualified Data.Text as T @@ -35,9 +37,14 @@ import Database.Persist (Entity (..), delete, entityVal, get, insert, selectList, (==.)) import Database.Persist.Sql (PersistFieldSql, SqlBackend, runSqlPool) +import Extrapolation (Extrapolator (..), + LinearExtrapolator (..)) import Fmt ((+|), (|+)) import GHC.Float (int2Double) import GHC.Generics (Generic) +import GTFS +import Numeric (showFFloat) +import Persist import Server.Util (Service, secondsNow) import Text.Blaze.Html (ToMarkup (..)) import Text.Blaze.Internal (MarkupM (Empty)) @@ -46,16 +53,9 @@ import Text.Shakespeare.Text import Yesod import Yesod.Auth import Yesod.Auth.OAuth2.Prelude -import Yesod.Form - -import Config (ServerConfig (..), UffdConfig (..)) -import Extrapolation (Extrapolator (..), - LinearExtrapolator (..)) -import GTFS -import Numeric (showFFloat) -import Persist import Yesod.Auth.OpenId (IdentifierType (..), authOpenId) import Yesod.Auth.Uffd (UffdUser (..), uffdClient) +import Yesod.Form import Yesod.Orphans () @@ -71,15 +71,16 @@ mkYesod "ControlRoom" [parseRoutes| / RootR GET /auth AuthR Auth getAuth /trains TrainsR GET -/train/id/#TripID/#Day TrainViewR GET -/train/map/#TripID/#Day TrainMapViewR GET -/train/announce/#TripID/#Day AnnounceR POST +/train/id/#UUID TicketViewR GET +/train/import/#Day TicketImportR POST +/train/map/#UUID TrainMapViewR GET +/train/announce/#UUID AnnounceR POST /train/del-announce/#UUID DelAnnounceR GET /token/block/#Token TokenBlock GET /trips TripsViewR GET -/trip/#TripID TripViewR GET +/trip/#TripId TripViewR GET /obu OnboardUnitMenuR GET -/obu/#TripID/#Day OnboardUnitR GET +/obu/#TripId/#Day OnboardUnitR GET |] emptyMarkup :: MarkupM a -> Bool @@ -191,7 +192,17 @@ getTrainsR = do let prevday = (T.pack . iso8601Show . addDays (-1)) day let nextday = (T.pack . iso8601Show . addDays 1) day gtfs <- getYesod <&> getGtfs + + -- TODO: tickets should have all trip information saved + tickets <- runDB $ selectList [ TicketDay ==. day ] [] + <&> fmap (\(Entity (TicketKey ticketId) ticket) -> + (ticketId, ticket, fromJust $ M.lookup (ticketTrip ticket) (trips gtfs))) + let trips = tripsOnDay gtfs day + let headsign (Trip{..} :: Trip Deep Deep) = case tripHeadsign of + Just headsign -> headsign + Nothing -> stationName (stopStation (V.last tripStops)) + (widget, enctype) <- generateFormPost (tripImportForm (fmap (,day) (M.elems trips))) defaultLayout $ do [whamlet| <h1> _{MsgTrainsOnDay (iso8601Show day)} @@ -205,38 +216,71 @@ $maybe name <- mdisplayname <a href="@{TrainsR}">_{Msgtoday} <a class="nav-right" href="@?{(TrainsR, [("day", nextday)])}">#{nextday} → <section> + <h2>_{MsgTickets} <ol> - $forall trip@Trip{..} <- trips - <li><a href="@{TrainViewR tripTripID day}">_{MsgTrip} #{tripName trip}</a> - : _{Msgdep} #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} - $if null trips + $forall (ticketId, Ticket{..}, trip@Trip{..}) <- tickets + <li><a href="@{TicketViewR ticketId}">_{MsgTrip} #{tripName trip}</a> + : _{Msgdep} #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} → #{headsign trip} + $if null tickets <li style="text-align: center"><em>(_{MsgNone}) +<section> + <h2>_{MsgAccordingToGtfs} + <form method=post action="@{TicketImportR day}" enctype=#{enctype}> + ^{widget} + <button>_{MsgImportTrips} |] -getTrainViewR :: TripID -> Day -> Handler Html -getTrainViewR trip day = do +postTicketImportR :: Day -> Handler Html +postTicketImportR day = do + gtfs <- getYesod <&> getGtfs + let trips = tripsOnDay gtfs day + ((result, widget), enctype) <- runFormPost (tripImportForm (fmap (,day) (M.elems trips))) + case result of + FormSuccess selected -> do + now <- liftIO getCurrentTime + let tickets = flip fmap selected $ \(Trip{..}, day) -> Ticket + { ticketTrip = tripTripId, ticketDay = day, ticketImported = now + , ticketSchedule_version = Nothing, ticketVehicle = Nothing } + runDB $ insertMany tickets + redirect (TrainsR, [("day", T.pack (iso8601Show day))]) + _ -> defaultLayout [whamlet| +<section> + <h2>_{MsgAccordingToGtfs} + <form method=post action="@{TicketImportR day}" enctype=#{enctype}> + ^{widget} + <button>_{MsgImportTrips} +|] + +getTicketViewR :: UUID -> Handler Html +getTicketViewR ticketId = do + Ticket{..} <- runDB $ get (TicketKey ticketId) + >>= \case {Nothing -> notFound; Just a -> pure a} + GTFS{..} <- getYesod <&> getGtfs - (widget, enctype) <- generateFormPost (announceForm day trip) - case M.lookup trip trips of + (widget, enctype) <- generateFormPost (announceForm ticketId) + case M.lookup ticketTrip trips of Nothing -> notFound Just res@Trip{..} -> do - anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] [] - tokens <- runDB $ selectList [ RunningTrip ==. trip, RunningDay ==. day ] [Asc RunningExpires] - lastPing <- runDB $ selectFirst [ TrainPingToken <-. fmap entityKey tokens ] [Desc TrainPingTimestamp] - anchors <- runDB $ selectList [ TrainAnchorTrip ==. trip, TrainAnchorDay ==. day ] [] + let ticketKey = TicketKey ticketId + anns <- runDB $ selectList [ AnnouncementTicket ==. ticketKey ] [] + trackerIds <- runDB $ selectList [ TrackerTicketTicket ==. ticketKey ] [] + <&> fmap (trackerTicketTracker . entityVal) + trackers <- runDB $ selectList [ TrackerId <-. trackerIds ] [Asc TrackerExpires] + lastPing <- runDB $ selectFirst [ TrainPingToken <-. fmap entityKey trackers ] [Desc TrainPingTimestamp] + anchors <- runDB $ selectList [ TrainAnchorTicket ==. ticketKey ] [] <&> nonEmpty . fmap entityVal - nowSeconds <- secondsNow day + nowSeconds <- secondsNow ticketDay defaultLayout $ do mr <- getMessageRender - setTitle (toHtml (""+|mr MsgTrip|+" "+|tripTripID|+" "+|mr Msgon|+" "+|day|+"" :: Text)) + setTitle (toHtml (""+|mr MsgTrip|+" "+|tripTripId|+" "+|mr Msgon|+" "+|ticketDay|+"" :: Text)) [whamlet| -<h1>_{MsgTrip} <a href="@{TripViewR tripTripID}">#{tripName res}</a> _{Msgon} <a href="@?{(TrainsR, [("day", T.pack (iso8601Show day))])}">#{day}</a> +<h1>_{MsgTrip} <a href="@{TripViewR tripTripId}">#{tripName res}</a> _{Msgon} <a href="@?{(TrainsR, [("day", T.pack (iso8601Show ticketDay))])}">#{ticketDay}</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>) + (<a href="/api/debug/pings/#{UUID.toString ticketId}/#{ticketDay}">_{Msgraw}</a>) $nothing <em>(_{MsgNoTrainPing}) <p><strong>_{MsgEstimatedDelay}</strong>: @@ -245,7 +289,7 @@ getTrainViewR trip day = do \ #{trainAnchorDelay} (_{MsgOnStationSequence (showFFloat (Just 3) trainAnchorSequence "")}) $nothing <em> (_{MsgNone}) - <p><a href="@{TrainMapViewR tripTripID day}">_{MsgMap}</a> + <p><a href="@{TrainMapViewR ticketId}">_{MsgMap}</a> <section> <h2>_{MsgStops} <ol> @@ -262,21 +306,21 @@ getTrainViewR trip day = do $if null anns <li><em>(_{MsgNone})</em> <h3>_{MsgNewAnnouncement} - <form method=post action=@{AnnounceR trip day} enctype=#{enctype}> + <form method=post action=@{AnnounceR ticketId} enctype=#{enctype}> ^{widget} <button>_{MsgSubmit} <section> <h2>_{MsgTokens} <table> <tr><th style="width: 20%">_{MsgAgent}</th><th style="width: 50%">_{MsgToken}</th><th>_{MsgExpires}</th><th>_{MsgStatus}</th> - $if null tokens + $if null trackers <tr><td></td><td style="text-align:center"><em>(_{MsgNone}) - $forall Entity (RunningKey key) Running{..} <- tokens - <tr :runningBlocked:.blocked> - <td title="#{runningAgent}">#{runningAgent} + $forall Entity (TrackerKey key) Tracker{..} <- trackers + <tr :trackerBlocked:.blocked> + <td title="#{trackerAgent}">#{trackerAgent} <td title="#{key}">#{key} - <td title="#{runningExpires}">#{runningExpires} - $if runningBlocked + <td title="#{trackerExpires}">#{trackerExpires} + $if trackerBlocked <td title="_{MsgUnblockToken}"><a href="@?{(TokenBlock key, [("unblock", "true")])}">_{MsgUnblockToken}</a> $else <td title="_{MsgBlockToken}"><a href="@{TokenBlock key}">_{MsgBlockToken}</a> @@ -285,14 +329,16 @@ getTrainViewR trip day = do guessAtSeconds = extrapolateAtSeconds LinearExtrapolator -getTrainMapViewR :: TripID -> Day -> Handler Html -getTrainMapViewR tripId day = do +getTrainMapViewR :: UUID -> Handler Html +getTrainMapViewR ticketId = do + Ticket{..} <- runDB $ get (TicketKey ticketId) + >>= \case { Nothing -> notFound ; Just ticket -> pure ticket } GTFS{..} <- getYesod <&> getGtfs - (widget, enctype) <- generateFormPost (announceForm day tripId) - case M.lookup tripId trips of + (widget, enctype) <- generateFormPost (announceForm ticketId) + case M.lookup ticketTrip trips of Nothing -> notFound Just res@Trip{..} -> do defaultLayout [whamlet| -<h1>_{MsgTrip} <a href="@{TrainViewR tripTripID day}">#{tripName res} _{Msgon} #{day}</a> +<h1>_{MsgTrip} <a href="@{TicketViewR ticketId}">#{tripName res} _{Msgon} #{ticketDay}</a> <link rel="stylesheet" href="https://unpkg.com/leaflet@1.9.3/dist/leaflet.css" integrity="sha256-kLaT2GOSpHechhsozzB+flnD+zUyjE2LlfWPgU04xyI=" crossorigin=""/> @@ -308,7 +354,7 @@ getTrainMapViewR tripId day = do attribution: '© <a href="https://www.openstreetmap.org/copyright">OpenStreetMap</a> contributors' }).addTo(map); - ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/train/subscribe/#{tripTripID}/#{day}"); + ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/train/subscribe/#{tripTripId}/#{ticketDay}"); var marker = null; @@ -336,12 +382,12 @@ getTripsViewR = do <h1>List of Trips <section><ul> $forall trip@Trip{..} <- trips - <li><a href="@{TripViewR tripTripID}">#{tripName trip}</a> + <li><a href="@{TripViewR tripTripId}">#{tripName trip}</a> : #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} |] -getTripViewR :: TripID -> Handler Html +getTripViewR :: TripId -> Handler Html getTripViewR tripId = do GTFS{..} <- getYesod <&> getGtfs case M.lookup tripId trips of @@ -350,7 +396,7 @@ getTripViewR tripId = do <h1>_{MsgTrip} #{tripName trip} <section> <h2>_{MsgInfo} - <p><strong>_{MsgtripId}:</strong> #{tripTripID} + <p><strong>_{MsgtripId}:</strong> #{tripTripId} <p><strong>_{MsgtripHeadsign}:</strong> #{mightbe tripHeadsign} <p><strong>_{MsgtripShortname}:</strong> #{mightbe tripShortName} <section> @@ -365,17 +411,17 @@ getTripViewR tripId = do |] -postAnnounceR :: TripID -> Day -> Handler Html -postAnnounceR trip day = do - ((result, widget), enctype) <- runFormPost (announceForm day trip) +postAnnounceR :: UUID -> Handler Html +postAnnounceR ticketId = do + ((result, widget), enctype) <- runFormPost (announceForm ticketId) case result of FormSuccess ann -> do runDB $ insert ann - redirect (TrainViewR trip day) + redirect RootR -- (TicketViewR trip day) _ -> defaultLayout [whamlet| <p>_{MsgInvalidInput}. - <form method=post action=@{AnnounceR trip day} enctype=#{enctype}> + <form method=post action=@{AnnounceR ticketId} enctype=#{enctype}> ^{widget} <button>_{MsgSubmit} |] @@ -389,19 +435,20 @@ getDelAnnounceR uuid = do case ann of Nothing -> notFound Just Announcement{..} -> - redirect (TrainViewR announcementTrip announcementDay) + let (TicketKey ticketId) = announcementTicket + in redirect (TicketViewR ticketId) 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) + update (TrackerKey token) [ TrackerBlocked =. blocked ] + get (TrackerKey token) case maybe of - Just r@Running{..} -> do + Just r@Tracker{..} -> do liftIO $ print r - redirect (TrainViewR runningTrip runningDay) + redirect RootR Nothing -> notFound getOnboardUnitMenuR :: Handler Html @@ -416,24 +463,55 @@ getOnboardUnitMenuR = do _{MsgChooseTrain} $forall Trip{..} <- trips <hr> - <a href="@{OnboardUnitR tripTripID day}"> - #{tripTripID}: #{stationName (stopStation (V.head tripStops))} #{stopDeparture (V.head tripStops)} + <a href="@{OnboardUnitR tripTripId day}"> + #{tripTripId}: #{stationName (stopStation (V.head tripStops))} #{stopDeparture (V.head tripStops)} |] -getOnboardUnitR :: TripID -> Day -> Handler Html +getOnboardUnitR :: TripId -> Day -> Handler Html getOnboardUnitR tripId day = defaultLayout $(whamletFile "site/obu.hamlet") -announceForm :: Day -> TripID -> Html -> MForm Handler (FormResult Announcement, Widget) -announceForm day tripId = renderDivs $ Announcement - <$> pure tripId +announceForm :: UUID -> Html -> MForm Handler (FormResult Announcement, Widget) +announceForm ticketId = renderDivs $ Announcement + <$> pure (TicketKey ticketId) <*> areq textField (fieldSettingsLabel MsgHeader) Nothing <*> areq textField (fieldSettingsLabel MsgText) Nothing - <*> pure day <*> aopt urlField (fieldSettingsLabel MsgMaybeWeblink) Nothing <*> lift (liftIO getCurrentTime <&> Just) + + +tripImportForm :: [(Trip Deep Deep, Day)] -> Html -> MForm Handler (FormResult [(Trip Deep Deep, Day)], Widget) +tripImportForm trips extra = do + forms <- forM trips $ \(trip, day) -> do + (aRes, aView) <- mreq checkBoxField "import" Nothing + let dings = fmap (\res -> if res then Just (trip, day) else Nothing) aRes + pure (trip, day, dings, aView) + + let widget = toWidget [whamlet| + #{extra} + <ol> + $forall (trip@Trip{..}, day, res, view) <- forms + <li> + ^{fvInput view} + <label for="^{fvId view}"> + _{MsgTrip} #{tripName trip} + : _{Msgdep} #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} → #{headsign trip} + |] + + let (a :: FormResult [Maybe (Trip Deep Deep, Day)]) = + sequenceA (fmap (\(_,_,res,_) -> res) forms) + + pure (fmap catMaybes a, widget) + + mightbe :: Maybe Text -> Text mightbe (Just a) = a mightbe Nothing = "" + +headsign :: Trip 'Deep 'Deep -> Text +headsign (Trip{..} :: Trip Deep Deep) = + case tripHeadsign of + Just headsign -> headsign + Nothing -> stationName (stopStation (V.last tripStops)) diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs index 740f71c..412284f 100644 --- a/lib/Server/GTFS_RT.hs +++ b/lib/Server/GTFS_RT.hs @@ -1,8 +1,9 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE DataKinds #-} module Server.GTFS_RT (gtfsRealtimeServer) where @@ -30,21 +31,22 @@ import qualified Data.UUID as UUID import qualified Data.Vector as V import Database.Persist (Entity (..), PersistQueryRead (selectFirst), - selectList, (==.)) + getJust, selectKeysList, + selectList, (<-.), (==.)) import Database.Persist.Postgresql (SqlBackend) import Extrapolation (Extrapolator (extrapolateAtPosition, extrapolateAtSeconds), LinearExtrapolator (..)) import GHC.Float (double2Float, int2Double) import GTFS (Depth (..), GTFS (..), Seconds (..), Stop (..), - Trip (..), TripID, + Trip (..), TripId, showTimeWithSeconds, stationId, toSeconds, toUTC, tripsOnDay) import Persist (Announcement (..), EntityField (..), Key (..), - Running (..), Token (..), - TrainAnchor (..), TrainPing (..), - runSql) + Ticket (..), Token (..), + Tracker (..), TrainAnchor (..), + TrainPing (..), runSql) import qualified Proto.GtfsRealtime as RT import qualified Proto.GtfsRealtime_Fields as RT import Servant.API ((:<|>) (..)) @@ -70,17 +72,20 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool = where handleServiceAlerts = runSql dbpool $ do announcements <- selectList [] [] - defFeedMessage (fmap mkAlert announcements) + alerts <- forM announcements $ \(Entity (AnnouncementKey uuid) announcement@Announcement{..}) -> do + ticket <- getJust announcementTicket + pure $ mkAlert uuid announcement ticket + defFeedMessage alerts where - mkAlert :: Entity Announcement -> RT.FeedEntity - mkAlert (Entity (AnnouncementKey uuid) Announcement{..}) = + mkAlert :: UUID.UUID -> Announcement -> Ticket -> RT.FeedEntity + mkAlert uuid Announcement{..} Ticket{..} = defMessage & RT.id .~ UUID.toText uuid & RT.alert .~ (defMessage & RT.activePeriod .~ [ defMessage :: RT.TimeRange ] & RT.informedEntity .~ [ defMessage - & RT.trip .~ defTripDescriptor announcementTrip (Just announcementDay) Nothing + & RT.trip .~ defTripDescriptor ticketTrip (Just ticketDay) Nothing ] & RT.maybe'url .~ fmap (monolingual "de") announcementUrl & RT.headerText .~ monolingual "de" announcementHeader @@ -92,7 +97,8 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool = nowSeconds <- secondsNow today let running = M.toList (tripsOnDay gtfs today) anchors <- flip mapMaybeM running $ \(tripId, trip@Trip{..}) -> do - entities <- selectList [TrainAnchorTrip ==. tripId, TrainAnchorDay ==. today] [] + tickets <- selectKeysList [TicketTrip ==. tripId, TicketDay ==. today] [] + entities <- selectList [TrainAnchorTicket <-. tickets] [] case nonEmpty (fmap entityVal entities) of Nothing -> pure Nothing Just anchors -> pure $ Just (tripId, trip, anchors) @@ -138,18 +144,23 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool = & RT.scheduleRelationship .~ RT.TripUpdate'StopTimeUpdate'SCHEDULED handleVehiclePositions = runSql dbpool $ do - (running :: [Entity Running]) <- selectList [] [] - pings <- forM running $ \(Entity key entity) -> do - selectFirst [TrainPingToken ==. key] [] <&> fmap (, entity) + (trackers :: [Entity Tracker]) <- selectList [] [] + pings <- forM trackers $ \(Entity trackerId tracker) -> do + selectFirst [TrainPingToken ==. trackerId] [] >>= \case + Nothing -> pure Nothing + Just ping -> do + ticket <- getJust (trainPingTicket (entityVal ping)) + pure (Just (ping, ticket, tracker)) + defFeedMessage (mkPosition <$> catMaybes pings) where - mkPosition :: (Entity TrainPing, Running) -> RT.FeedEntity - mkPosition (Entity (TrainPingKey key) TrainPing{..}, Running{..}) = defMessage + mkPosition :: (Entity TrainPing, Ticket, Tracker) -> RT.FeedEntity + mkPosition (Entity (TrainPingKey key) TrainPing{..}, Ticket{..}, Tracker{..}) = defMessage & RT.id .~ T.pack (show key) & RT.vehicle .~ (defMessage - & RT.trip .~ defTripDescriptor runningTrip Nothing Nothing - & RT.maybe'vehicle .~ case runningVehicle of + & RT.trip .~ defTripDescriptor ticketTrip Nothing Nothing + & RT.maybe'vehicle .~ case ticketVehicle of Nothing -> Nothing Just trainset -> Just $ defMessage & RT.label .~ trainset @@ -180,7 +191,7 @@ defFeedMessage entities = do ) & RT.entity .~ entities -defTripDescriptor :: TripID -> Maybe Day -> Maybe Text -> RT.TripDescriptor +defTripDescriptor :: TripId -> Maybe Day -> Maybe Text -> RT.TripDescriptor defTripDescriptor tripId day starttime = defMessage & RT.tripId .~ tripId & RT.scheduleRelationship .~ RT.TripDescriptor'SCHEDULED |