diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/Server/Frontend/Tickets.hs | 205 |
1 files changed, 130 insertions, 75 deletions
diff --git a/lib/Server/Frontend/Tickets.hs b/lib/Server/Frontend/Tickets.hs index 9b88a48..76146df 100644 --- a/lib/Server/Frontend/Tickets.hs +++ b/lib/Server/Frontend/Tickets.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE QuasiQuotes #-} @@ -10,48 +11,55 @@ module Server.Frontend.Tickets , getTicketMapViewR , getDelAnnounceR , postAnnounceR - , getTokenBlock + , getTrackerIdBlock ) where import Server.Frontend.Routes -import Config (ServerConfig (..), UffdConfig (..)) -import Control.Monad (forM, forM_, join) -import Control.Monad.Extra (maybeM) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Coerce (coerce) -import Data.Function (on, (&)) -import Data.Functor ((<&>)) -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, isJust) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time (UTCTime (..), addDays, - getCurrentTime, utctDay) -import Data.Time.Calendar (Day) -import Data.Time.Format.ISO8601 (iso8601Show) -import Data.UUID (UUID) -import qualified Data.UUID as UUID -import qualified Data.Vector as V -import Extrapolation (Extrapolator (..), - LinearExtrapolator (..)) -import Fmt ((+|), (|+)) -import GHC.Float (int2Double) +import Config (ServerConfig (..), + UffdConfig (..)) +import Control.Monad (forM, forM_, join) +import Control.Monad.Extra (maybeM) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Coerce (coerce) +import Data.Function (on, (&)) +import Data.Functor ((<&>)) +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, isJust) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (UTCTime (..), addDays, + getCurrentTime, utctDay) +import Data.Time.Calendar (Day) +import Data.Time.Format.ISO8601 (iso8601Show) +import Data.UUID (UUID) +import qualified Data.UUID as UUID +import qualified Data.Vector as V +import Extrapolation (Extrapolator (..), + LinearExtrapolator (..)) +import Fmt ((+|), (|+)) +import GHC.Float (int2Double) import qualified GTFS -import Numeric (showFFloat) +import Numeric (showFFloat) import Persist -import Server.Frontend.SpaceTime (mkSpaceTimeDiagram, - mkSpaceTimeDiagramHandler) -import Server.Frontend.Ticker (tickerWidget) -import Server.Util (Service, secondsNow) -import Text.Read (readMaybe) -import Yesod +import Server.Frontend.SpaceTime (mkSpaceTimeDiagram, + mkSpaceTimeDiagramHandler) +import Server.Frontend.Ticker (tickerWidget) +import Server.Util (Service, secondsNow) +import Text.Read (readMaybe) +import qualified Yesod +import Yesod hiding (delete, update, (=.), + (==.), (||.)) import Yesod.Auth -import Yesod.Auth.Uffd (UffdUser (..), uffdClient) +import Yesod.Auth.Uffd (UffdUser (..), uffdClient) +import Database.Esqueleto.Experimental (asc, associateJoin, orderBy, + where_, (:&) (..), (^.)) +import Database.Esqueleto.Experimental hiding (on, (<&>)) +import qualified Database.Esqueleto.Experimental as E getTicketsR :: Handler Html getTicketsR = do @@ -64,17 +72,23 @@ getTicketsR = do Just day -> (day, day == today) Nothing -> (today, True) - maybeSpaceTime <- mkSpaceTimeDiagramHandler 1 day [ TicketDay ==. day ] + maybeSpaceTime <- mkSpaceTimeDiagramHandler 1 day [ TicketDay Yesod.==. day ] 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 ] [ Asc TicketTripName ] >>= mapM (\ticket -> do - stops <- selectList [ StopTicket ==. entityKey ticket ] [] - startStation <- getJust (stopStation $ entityVal $ head stops) - pure (ticket, startStation, fmap entityVal stops)) + + tickets <- runDB $ E.select do + ((ticket :& stop) :& station) <- E.from $ + (E.table @Ticket `E.InnerJoin` E.table @Stop + `E.on` \(ticket :& stop) -> ticket ^. TicketId E.==. stop E.^. StopTicket) + `E.InnerJoin` E.table @Station `E.on` \((_ :& stop) :& station) -> stop E.^. StopStation E.==. station ^. StationId + where_ (ticket ^. TicketDay E.==. (E.val day)) + orderBy [asc (ticket ^. TicketTripName)] + pure (ticket, (stop, station)) + & fmap associateJoin let trips = GTFS.tripsOnDay gtfs day @@ -98,9 +112,9 @@ $maybe name <- mdisplayname <section> <h2>_{MsgTickets} <ol> - $forall (Entity (TicketKey ticketId) Ticket{..}, startStation, stops) <- tickets + $forall (TicketKey ticketId, (Ticket{..}, stops)) <- M.toList tickets <li><a href="@{TicketViewR ticketId}">_{MsgTrip} #{ticketTripName}</a> - : _{Msgdep} #{stopDeparture (head stops)} #{stationName startStation} → #{ticketHeadsign} + : _{Msgdep} #{stopDeparture (entityVal (fst (head stops)))} #{stationName (entityVal (snd (head stops)))} → #{ticketHeadsign} $if null tickets <li style="text-align: center"><em>(_{MsgNone})</em> $maybe spaceTime <- maybeSpaceTime @@ -144,16 +158,18 @@ postGtfsTicketImportR day = do <&> (\(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 + & mapM (\GTFS.Station{..} -> runDB $ E.selectOne do + station <- E.from (E.table @Station) + where_ (station ^. StationShortName E.==. E.val stationId) + pure station + >>= \case Nothing -> do key <- insert Station { stationGeopos = Geopos (stationLat, stationLon) , stationShortName = stationId , stationName } pure (stationId, key) Just (Entity key _) -> pure (stationId, key)) - <&> M.fromList + & fmap M.fromList selected <&> (\(trip@GTFS.Trip{..}, day) -> @@ -190,21 +206,52 @@ getTicketViewR ticketId = do Ticket{..} <- runDB $ get ticketKey >>= \case {Nothing -> notFound; Just a -> pure a} - stops <- runDB $ selectList [StopTicket ==. ticketKey] [] >>= mapM (\stop -> do - station <- getJust (stopStation (entityVal stop)) - pure (entityVal stop, station)) - - anns <- runDB $ selectList [ AnnouncementTicket ==. ticketKey ] [] - joins <- runDB $ selectList [ TrackerTicketTicket ==. ticketKey ] [] - <&> fmap (trackerTicketTracker . entityVal) - trackers <- runDB $ selectList - ([ TrackerId <-. joins ] ||. [ TrackerCurrentTicket ==. Just ticketKey ]) - [Asc TrackerExpires] - lastPing <- runDB $ selectFirst [ TrainPingTicket ==. coerce ticketId ] [Desc TrainPingTimestamp] - anchors <- runDB $ selectList [ TrainAnchorTicket ==. ticketKey ] [] + stops <- runDB $ select do + (stop :& station) <- from $ table @Stop `innerJoin` table @Station + `E.on` \(stop :& station) -> stop ^. StopStation ==. station ^. StationId + where_ (stop ^. StopTicket ==. val ticketKey) + pure (stop, station) + -- & fmap associateJoin + -- stops <- runDB $ selectList [StopTicket ==. ticketKey] [] >>= mapM (\stop -> do + -- station <- getJust (stopStation (entityVal stop)) + -- pure (entityVal stop, station)) + + anns <- runDB $ select do + ann <- from (table @Announcement) + where_ (ann ^. AnnouncementTicket ==. val ticketKey) + pure ann + + -- anns <- runDB $ selectList [ AnnouncementTicket ==. ticketKey ] [] + + trackers <- runDB $ select do + (tt :& tracker) <- from $ + table @TrackerTicket `innerJoin` table @Tracker + `E.on` \(tt :& tracker) -> tracker ^. TrackerId ==. tt ^. TrackerTicketTracker + where_ (tt ^. TrackerTicketTicket ==. val ticketKey + ||. tracker ^. TrackerCurrentTicket ==. val (Just ticketKey)) + pure tracker + + lastPing <- runDB $ selectOne do + trainping <- from $ table @Ping + where_ (trainping ^. PingTicket ==. val (Just (coerce ticketId))) + orderBy [desc (trainping ^. PingTimestamp)] + pure trainping + + anchors <- runDB $ select do + anchor <- from $ table @TrainAnchor + where_ (anchor ^. TrainAnchorTicket ==. val ticketKey) + pure anchor <&> nonEmpty . fmap entityVal + -- joins <- runDB $ selectList [ TrackerTicketTicket ==. ticketKey ] [] + -- <&> fmap (trackerTicketTracker . entityVal) + -- trackers <- runDB $ selectList + -- ([ TrackerId <-. joins ] ||. [ TrackerCurrentTicket ==. Just ticketKey ]) + -- [Asc TrackerExpires] + -- lastPing <- runDB $ selectFirst [ PingTicket ==. coerce ticketId ] [Desc PingTimestamp] + -- anchors <- runDB $ selectList [ TrainAnchorTicket ==. ticketKey ] [] + -- <&> nonEmpty . fmap entityVal - spaceTimeMaybe <- mkSpaceTimeDiagramHandler 2 ticketDay [ TicketId ==. coerce ticketId ] + spaceTimeMaybe <- mkSpaceTimeDiagramHandler 2 ticketDay [ TicketId Yesod.==. coerce ticketId ] (widget, enctype) <- generateFormPost (announceForm ticketId) @@ -220,11 +267,11 @@ getTicketViewR ticketId = do <section> <h2>_{MsgLive} <p><strong>_{MsgLastPing}: </strong> - $maybe Entity _ TrainPing{..} <- lastPing - _{MsgTrainPing (latitude trainPingGeopos) (longitude trainPingGeopos) trainPingTimestamp} + $maybe Entity _ Ping{..} <- lastPing + _{MsgPing (latitude pingGeopos) (longitude pingGeopos) pingTimestamp} (<a href="/api/debug/pings/#{UUID.toString ticketId}/#{ticketDay}">_{Msgraw}</a>) $nothing - <em>(_{MsgNoTrainPing}) + <em>(_{MsgNoPing}) <p><strong>_{MsgEstimatedDelay}</strong>: $maybe history <- anchors $maybe TrainAnchor{..} <- guessAtSeconds history nowSeconds @@ -235,7 +282,7 @@ getTicketViewR ticketId = do <section> <h2>_{MsgStops} <ol> - $forall (Stop{..}, Station{..}) <- stops + $forall (Entity _ Stop{..}, Entity _ Station{..}) <- stops <li value="#{stopSequence}"> #{stopArrival} #{stationName} $maybe history <- anchors $maybe delay <- guessDelay history (int2Double stopSequence) @@ -255,9 +302,9 @@ $maybe spaceTime <- spaceTimeMaybe ^{widget} <button>_{MsgSubmit} <section> - <h2>_{MsgTokens} + <h2>_{MsgTrackerIds} <table> - <tr><th style="width: 20%">_{MsgAgent}</th><th style="width: 50%">_{MsgToken}</th><th>_{MsgExpires}</th><th>_{MsgStatus}</th> + <tr><th style="width: 20%">_{MsgAgent}</th><th style="width: 50%">_{MsgTrackerId}</th><th>_{MsgExpires}</th><th>_{MsgStatus}</th> $if null trackers <tr><td></td><td style="text-align:center"><em>(_{MsgNone}) $forall Entity (TrackerKey key) Tracker{..} <- trackers @@ -266,9 +313,9 @@ $maybe spaceTime <- spaceTimeMaybe <td title="#{key}">#{key} <td title="#{trackerExpires}">#{trackerExpires} $if trackerBlocked - <td title="_{MsgUnblockToken}"><a href="@?{(TokenBlock key, [("unblock", "true")])}">_{MsgUnblockToken}</a> + <td title="_{MsgUnblockTrackerId}"><a href="@?{(TrackerIdBlock (TrackerKey key), [("unblock", "true")])}">_{MsgUnblockTrackerId}</a> $else - <td title="_{MsgBlockToken}"><a href="@{TokenBlock key}">_{MsgBlockToken}</a> + <td title="_{MsgBlockTrackerId}"><a href="@{TrackerIdBlock (TrackerKey key)}">_{MsgBlockTrackerId}</a> |] where guessDelay history = fmap trainAnchorDelay . extrapolateAtPosition LinearExtrapolator history guessAtSeconds = extrapolateAtSeconds LinearExtrapolator @@ -279,9 +326,12 @@ getTicketMapViewR ticketId = do Ticket{..} <- runDB $ get (TicketKey ticketId) >>= \case { Nothing -> notFound ; Just ticket -> pure ticket } - stops <- runDB $ selectList [StopTicket ==. TicketKey ticketId] [] >>= mapM (\stop -> do - station <- getJust (stopStation (entityVal stop)) - pure (entityVal stop, station)) + -- stops <- runDB $ E.select do + -- (stop :& station) <- E.from $ + -- E.table @Stop `E.InnerJoin` E.table @Station + -- `E.on` \(stop :& station) -> stop ^. StopStation E.==. station E.^. StationId + -- where_ (stop ^. StopTicket E.==. (E.val (TicketKey ticketId))) + -- pure (stop, station) (widget, enctype) <- generateFormPost (announceForm ticketId) @@ -380,7 +430,9 @@ getDelAnnounceR :: UUID -> Handler Html getDelAnnounceR uuid = do ann <- runDB $ do a <- get (AnnouncementKey uuid) - delete (AnnouncementKey uuid) + delete do + ann <- from (table @Announcement) + where_ (ann ^. AnnouncementId ==. val (AnnouncementKey uuid)) pure a case ann of Nothing -> notFound @@ -388,13 +440,16 @@ getDelAnnounceR uuid = do let (TicketKey ticketId) = announcementTicket in redirect (TicketViewR ticketId) -getTokenBlock :: Token -> Handler Html -getTokenBlock token = do +getTrackerIdBlock :: TrackerId -> Handler Html +getTrackerIdBlock trackerId = do YesodRequest{..} <- getRequest let blocked = lookup "unblock" reqGetParams /= Just "true" - maybe <- runDB $ do - update (TrackerKey token) [ TrackerBlocked =. blocked ] - get (TrackerKey token) + maybe <- runDB do + update \tracker -> do + set tracker [TrackerBlocked =. val blocked] + where_ (tracker ^. TrackerId ==. val trackerId) + -- Yesod.update (TrackerKey trackerId) [ TrackerBlocked Yesod.=. blocked ] + get trackerId case maybe of Just r@Tracker{..} -> do liftIO $ print r |