diff options
Diffstat (limited to 'lib/Server/ControlRoom.hs')
-rw-r--r-- | lib/Server/ControlRoom.hs | 274 |
1 files changed, 172 insertions, 102 deletions
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs index 4fb5ba8..e89b184 100644 --- a/lib/Server/ControlRoom.hs +++ b/lib/Server/ControlRoom.hs @@ -17,12 +17,13 @@ import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Data.Aeson as A import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as LB +import Data.Function (on, (&)) import Data.Functor ((<&>)) -import Data.List (lookup) +import Data.List (lookup, nubBy) import Data.List.NonEmpty (nonEmpty) import Data.Map (Map) import qualified Data.Map as M -import Data.Maybe (catMaybes, fromJust) +import Data.Maybe (catMaybes, fromJust, isJust) import Data.Pool (Pool) import Data.Text (Text) import qualified Data.Text as T @@ -42,7 +43,7 @@ import Extrapolation (Extrapolator (..), import Fmt ((+|), (|+)) import GHC.Float (int2Double) import GHC.Generics (Generic) -import GTFS +import qualified GTFS import Numeric (showFFloat) import Persist import Server.Util (Service, secondsNow) @@ -60,7 +61,7 @@ import Yesod.Orphans () data ControlRoom = ControlRoom - { getGtfs :: GTFS + { getGtfs :: GTFS.GTFS , getPool :: Pool SqlBackend , getSettings :: ServerConfig } @@ -70,17 +71,21 @@ mkMessage "ControlRoom" "messages" "en" mkYesod "ControlRoom" [parseRoutes| / RootR GET /auth AuthR Auth getAuth -/trains TrainsR GET -/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 + +/tickets TicketsR GET +/ticket/#UUID TicketViewR GET +/ticket/map/#UUID TicketMapViewR GET +/ticket/announce/#UUID AnnounceR POST +/ticket/del-announce/#UUID DelAnnounceR GET + /token/block/#Token TokenBlock GET -/trips TripsViewR GET -/trip/#TripId TripViewR GET + +/gtfs/trips GtfsTripsViewR GET +/gtfs/trip/#GTFS.TripId GtfsTripViewR GET +/gtfs/import/#Day GtfsTicketImportR POST + /obu OnboardUnitMenuR GET -/obu/#TripId/#Day OnboardUnitR GET +/obu/#UUID OnboardUnitR GET |] emptyMarkup :: MarkupM a -> Bool @@ -90,10 +95,10 @@ emptyMarkup _ = False instance Yesod ControlRoom where authRoute _ = Just $ AuthR LoginR isAuthorized OnboardUnitMenuR _ = pure Authorized - isAuthorized (OnboardUnitR _ _) _ = pure Authorized + isAuthorized (OnboardUnitR _) _ = pure Authorized isAuthorized (AuthR _) _ = pure Authorized isAuthorized _ _ = do - UffdConfig{..} <- getYesod <&> getSettings <&> serverConfigLogin + UffdConfig{..} <- getYesod <&> serverConfigLogin . getSettings if uffdConfigEnable then maybeAuthId >>= \case Just _ -> pure Authorized Nothing -> pure AuthenticationRequired @@ -176,10 +181,10 @@ instance YesodAuth ControlRoom where getRootR :: Handler Html -getRootR = redirect TrainsR +getRootR = redirect TicketsR -getTrainsR :: Handler Html -getTrainsR = do +getTicketsR :: Handler Html +getTicketsR = do req <- getRequest let maybeDay = lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack) mdisplayname <- maybeAuthId <&> fmap uffdDisplayName @@ -194,14 +199,13 @@ getTrainsR = do 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)) + tickets <- runDB $ selectList [ TicketDay ==. day ] [] >>= mapM (\ticket -> do + stops <- selectList [ StopTicket ==. entityKey ticket ] [] + startStation <- getJust (stopStation $ entityVal $ head stops) + pure (ticket, startStation, fmap entityVal stops)) + + let trips = GTFS.tripsOnDay gtfs day + (widget, enctype) <- generateFormPost (tripImportForm (fmap (,day) (M.elems trips))) defaultLayout $ do [whamlet| @@ -209,77 +213,130 @@ getTrainsR = do $maybe name <- mdisplayname <p>_{MsgLoggedInAs name} - <a href="@{AuthR LogoutR}">_{MsgLogout}</a> <nav> - <a class="nav-left" href="@?{(TrainsR, [("day", prevday)])}">← #{prevday} + <a class="nav-left" href="@?{(TicketsR, [("day", prevday)])}">← #{prevday} $if isToday _{Msgtoday} $else - <a href="@{TrainsR}">_{Msgtoday} - <a class="nav-right" href="@?{(TrainsR, [("day", nextday)])}">#{nextday} → + <a href="@{TicketsR}">_{Msgtoday} + <a class="nav-right" href="@?{(TicketsR, [("day", nextday)])}">#{nextday} → <section> <h2>_{MsgTickets} <ol> - $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} + $forall (Entity (TicketKey ticketId) Ticket{..}, startStation, stops) <- tickets + <li><a href="@{TicketViewR ticketId}">_{MsgTrip} #{ticketTripName}</a> + : _{Msgdep} #{stopDeparture (head stops)} #{stationName startStation} → #{ticketHeadsign} $if null tickets <li style="text-align: center"><em>(_{MsgNone}) <section> <h2>_{MsgAccordingToGtfs} - <form method=post action="@{TicketImportR day}" enctype=#{enctype}> + <form method=post action="@{GtfsTicketImportR day}" enctype=#{enctype}> ^{widget} <button>_{MsgImportTrips} |] -postTicketImportR :: Day -> Handler Html -postTicketImportR day = do + +-- TODO: this function should probably look for duplicate imports +postGtfsTicketImportR :: Day -> Handler Html +postGtfsTicketImportR day = do gtfs <- getYesod <&> getGtfs - let trips = tripsOnDay gtfs day + let trips = GTFS.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| + + shapeMap <- selected + <&> (\(trip@GTFS.Trip{..}, _) -> (GTFS.shapeId tripShape, tripShape)) + & nubBy ((==) `on` fst) + & mapM (\(shapeId, shape) -> runDB $ do + key <- insert Shape + insertMany + $ shape + & GTFS.shapePoints + & V.indexed + & V.toList + <&> \(idx, pos) -> ShapePoint (Geopos pos) idx key + pure (shapeId, key)) + <&> M.fromList + + stationMap <- selected + <&> (\(trip@GTFS.Trip{..}, _) -> V.toList (tripStops <&> GTFS.stopStation)) + & concat + & nubBy ((==) `on` GTFS.stationId) + & mapM (\GTFS.Station{..} -> runDB $ do + maybeExists <- selectFirst [ StationShortName ==. stationId ] [] + case maybeExists of + Nothing -> do + key <- insert Station + { stationGeopos = Geopos (stationLat, stationLon) + , stationShortName = stationId , stationName } + pure (stationId, key) + Just (Entity key _) -> pure (stationId, key)) + <&> M.fromList + + selected + <&> (\(trip@GTFS.Trip{..}, day) -> + let + ticket = Ticket + { ticketTripName = tripTripId, ticketDay = day, ticketImported = now + , ticketSchedule_version = Nothing, ticketVehicle = Nothing + , ticketCompleted = False, ticketHeadsign = gtfsHeadsign trip + , ticketShape = fromJust (M.lookup (GTFS.shapeId tripShape) shapeMap)} + stops = V.toList tripStops <&> \GTFS.Stop{..} ticketId -> Stop + { stopTicket = ticketId + , stopStation = fromJust (M.lookup (GTFS.stationId stopStation) stationMap) + , stopArrival, stopDeparture, stopSequence} + in (ticket, stops)) + & unzip + & \(tickets, stops) -> runDB $ do + ticketIds <- insertMany tickets + forM (zip ticketIds stops) $ \(ticketId, unfinishedStops) -> + insertMany (fmap (\s -> s ticketId) unfinishedStops) + + redirect (TicketsR, [("day", T.pack (iso8601Show day))]) + + FormFailure _ -> defaultLayout [whamlet| <section> <h2>_{MsgAccordingToGtfs} - <form method=post action="@{TicketImportR day}" enctype=#{enctype}> + <form method=post action="@{GtfsTicketImportR day}" enctype=#{enctype}> ^{widget} <button>_{MsgImportTrips} |] getTicketViewR :: UUID -> Handler Html getTicketViewR ticketId = do - Ticket{..} <- runDB $ get (TicketKey ticketId) + let ticketKey = TicketKey ticketId + Ticket{..} <- runDB $ get ticketKey >>= \case {Nothing -> notFound; Just a -> pure a} - GTFS{..} <- getYesod <&> getGtfs + stops <- runDB $ selectList [StopTicket ==. ticketKey] [] >>= mapM (\stop -> do + station <- getJust (stopStation (entityVal stop)) + pure (entityVal stop, station)) + + 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 + (widget, enctype) <- generateFormPost (announceForm ticketId) - case M.lookup ticketTrip trips of - Nothing -> notFound - Just res@Trip{..} -> do - 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 ticketDay - defaultLayout $ do - mr <- getMessageRender - 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 ticketDay))])}">#{ticketDay}</a> + + nowSeconds <- secondsNow ticketDay + defaultLayout $ do + mr <- getMessageRender + setTitle (toHtml (""+|mr MsgTrip|+" "+|ticketTripName|+" "+|mr Msgon|+" "+|ticketDay|+"" :: Text)) + [whamlet| +<h1>_{MsgTrip} # + <a href="@{GtfsTripViewR ticketTripName}">#{ticketTripName} + _{Msgon} + <a href="@?{(TicketsR, [("day", T.pack (iso8601Show ticketDay))])}">#{ticketDay} <section> <h2>_{MsgLive} <p><strong>_{MsgLastPing}: </strong> $maybe Entity _ TrainPing{..} <- lastPing - _{MsgTrainPing trainPingLat trainPingLong trainPingTimestamp} + _{MsgTrainPing (latitude trainPingGeopos) (longitude trainPingGeopos) trainPingTimestamp} (<a href="/api/debug/pings/#{UUID.toString ticketId}/#{ticketDay}">_{Msgraw}</a>) $nothing <em>(_{MsgNoTrainPing}) @@ -289,12 +346,12 @@ getTicketViewR ticketId = do \ #{trainAnchorDelay} (_{MsgOnStationSequence (showFFloat (Just 3) trainAnchorSequence "")}) $nothing <em> (_{MsgNone}) - <p><a href="@{TrainMapViewR ticketId}">_{MsgMap}</a> + <p><a href="@{TicketMapViewR ticketId}">_{MsgMap}</a> <section> <h2>_{MsgStops} <ol> - $forall Stop{..} <- tripStops - <li value="#{stopSequence}"> #{stopArrival} #{stationName stopStation} + $forall (Stop{..}, Station{..}) <- stops + <li value="#{stopSequence}"> #{stopArrival} #{stationName} $maybe history <- anchors $maybe delay <- guessDelay history (int2Double stopSequence) \ (#{delay}) @@ -329,16 +386,19 @@ getTicketViewR ticketId = do guessAtSeconds = extrapolateAtSeconds LinearExtrapolator -getTrainMapViewR :: UUID -> Handler Html -getTrainMapViewR ticketId = do +getTicketMapViewR :: UUID -> Handler Html +getTicketMapViewR ticketId = do Ticket{..} <- runDB $ get (TicketKey ticketId) >>= \case { Nothing -> notFound ; Just ticket -> pure ticket } - GTFS{..} <- getYesod <&> getGtfs + + stops <- runDB $ selectList [StopTicket ==. TicketKey ticketId] [] >>= mapM (\stop -> do + station <- getJust (stopStation (entityVal stop)) + pure (entityVal stop, station)) + (widget, enctype) <- generateFormPost (announceForm ticketId) - case M.lookup ticketTrip trips of - Nothing -> notFound - Just res@Trip{..} -> do defaultLayout [whamlet| -<h1>_{MsgTrip} <a href="@{TicketViewR ticketId}">#{tripName res} _{Msgon} #{ticketDay}</a> + + defaultLayout [whamlet| +<h1>_{MsgTrip} <a href="@{TicketViewR ticketId}">#{ticketTripName} _{Msgon} #{ticketDay}</a> <link rel="stylesheet" href="https://unpkg.com/leaflet@1.9.3/dist/leaflet.css" integrity="sha256-kLaT2GOSpHechhsozzB+flnD+zUyjE2LlfWPgU04xyI=" crossorigin=""/> @@ -354,7 +414,7 @@ getTrainMapViewR ticketId = 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}/#{ticketDay}"); + ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/train/subscribe/#{UUID.toText ticketId}"); var marker = null; @@ -373,27 +433,27 @@ getTrainMapViewR ticketId = do -getTripsViewR :: Handler Html -getTripsViewR = do - GTFS{..} <- getYesod <&> getGtfs +getGtfsTripsViewR :: Handler Html +getGtfsTripsViewR = do + GTFS.GTFS{..} <- getYesod <&> getGtfs defaultLayout $ do setTitle "List of Trips" [whamlet| <h1>List of Trips <section><ul> - $forall trip@Trip{..} <- trips - <li><a href="@{TripViewR tripTripId}">#{tripName trip}</a> - : #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} + $forall trip@GTFS.Trip{..} <- trips + <li><a href="@{GtfsTripViewR tripTripId}">#{GTFS.tripName trip}</a> + : #{GTFS.stopDeparture (V.head tripStops)} #{GTFS.stationName (GTFS.stopStation (V.head tripStops))} |] -getTripViewR :: TripId -> Handler Html -getTripViewR tripId = do - GTFS{..} <- getYesod <&> getGtfs +getGtfsTripViewR :: GTFS.TripId -> Handler Html +getGtfsTripViewR tripId = do + GTFS.GTFS{..} <- getYesod <&> getGtfs case M.lookup tripId trips of Nothing -> notFound - Just trip@Trip{..} -> defaultLayout [whamlet| -<h1>_{MsgTrip} #{tripName trip} + Just trip@GTFS.Trip{..} -> defaultLayout [whamlet| +<h1>_{MsgTrip} #{GTFS.tripName trip} <section> <h2>_{MsgInfo} <p><strong>_{MsgtripId}:</strong> #{tripTripId} @@ -402,8 +462,8 @@ getTripViewR tripId = do <section> <h2>_{MsgStops} <ol> - $forall Stop{..} <- tripStops - <div>(#{stopSequence}) #{stopArrival} #{stationName stopStation} + $forall GTFS.Stop{..} <- tripStops + <div>(#{stopSequence}) #{stopArrival} #{GTFS.stationName stopStation} <section> <h2>Dates <ul> @@ -454,21 +514,28 @@ getTokenBlock token = do getOnboardUnitMenuR :: Handler Html getOnboardUnitMenuR = do day <- liftIO getCurrentTime <&> utctDay - gtfs <- getYesod <&> getGtfs - let trips = tripsOnDay gtfs day + + tickets <- + runDB $ selectList [ TicketCompleted ==. False, TicketDay ==. day ] [] >>= mapM (\ticket -> do + firstStop <- selectFirst [StopTicket ==. entityKey ticket] [ Asc StopDeparture ] + pure (ticket, entityVal $ fromJust firstStop)) + defaultLayout $ do [whamlet| <h1>_{MsgOBU} <section> _{MsgChooseTrain} - $forall Trip{..} <- trips + $forall (Entity (TicketKey ticketId) Ticket{..}, firstStop) <- tickets <hr> - <a href="@{OnboardUnitR tripTripId day}"> - #{tripTripId}: #{stationName (stopStation (V.head tripStops))} #{stopDeparture (V.head tripStops)} + <a href="@{OnboardUnitR ticketId}"> + #{ticketTripName}: #{ticketHeadsign} #{stopDeparture firstStop} |] -getOnboardUnitR :: TripId -> Day -> Handler Html -getOnboardUnitR tripId day = +getOnboardUnitR :: UUID -> Handler Html +getOnboardUnitR ticketId = do + Ticket{..} <- runDB $ get (TicketKey ticketId) >>= \case + Nothing -> notFound + Just ticket -> pure ticket defaultLayout $(whamletFile "site/obu.hamlet") announceForm :: UUID -> Html -> MForm Handler (FormResult Announcement, Widget) @@ -481,7 +548,10 @@ announceForm ticketId = renderDivs $ Announcement -tripImportForm :: [(Trip Deep Deep, Day)] -> Html -> MForm Handler (FormResult [(Trip Deep Deep, Day)], Widget) +tripImportForm + :: [(GTFS.Trip GTFS.Deep GTFS.Deep, Day)] + -> Html + -> MForm Handler (FormResult [(GTFS.Trip GTFS.Deep GTFS.Deep, Day)], Widget) tripImportForm trips extra = do forms <- forM trips $ \(trip, day) -> do (aRes, aView) <- mreq checkBoxField "import" Nothing @@ -491,15 +561,15 @@ tripImportForm trips extra = do let widget = toWidget [whamlet| #{extra} <ol> - $forall (trip@Trip{..}, day, res, view) <- forms + $forall (trip@GTFS.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} + _{MsgTrip} #{GTFS.tripName trip} + : _{Msgdep} #{GTFS.stopDeparture (V.head tripStops)} #{GTFS.stationName (GTFS.stopStation (V.head tripStops))} → #{gtfsHeadsign trip} |] - let (a :: FormResult [Maybe (Trip Deep Deep, Day)]) = + let (a :: FormResult [Maybe (GTFS.Trip GTFS.Deep GTFS.Deep, Day)]) = sequenceA (fmap (\(_,_,res,_) -> res) forms) pure (fmap catMaybes a, widget) @@ -510,8 +580,8 @@ mightbe (Just a) = a mightbe Nothing = "" -headsign :: Trip 'Deep 'Deep -> Text -headsign (Trip{..} :: Trip Deep Deep) = +gtfsHeadsign :: GTFS.Trip GTFS.Deep GTFS.Deep -> Text +gtfsHeadsign GTFS.Trip{..} = case tripHeadsign of Just headsign -> headsign - Nothing -> stationName (stopStation (V.last tripStops)) + Nothing -> GTFS.stationName (GTFS.stopStation (V.last tripStops)) |