diff options
Diffstat (limited to 'lib/Server')
| -rw-r--r-- | lib/Server/Frontend/Ticker.hs | 26 | ||||
| -rw-r--r-- | lib/Server/Frontend/Tickets.hs | 116 | ||||
| -rw-r--r-- | lib/Server/GTFS_RT.hs | 27 | ||||
| -rw-r--r-- | lib/Server/Subscribe.hs | 33 |
4 files changed, 142 insertions, 60 deletions
diff --git a/lib/Server/Frontend/Ticker.hs b/lib/Server/Frontend/Ticker.hs index 861197a..7fc2874 100644 --- a/lib/Server/Frontend/Ticker.hs +++ b/lib/Server/Frontend/Ticker.hs @@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE BlockArguments #-} module Server.Frontend.Ticker (tickerWidget, postTickerAnnounceR, postTickerDeleteR) where import Data.Functor ((<&>)) @@ -7,7 +8,8 @@ import Persist (EntityField (TickerAnnouncementArchived TickerAnnouncement (..)) import Server.Frontend.Routes (FrontendMessage (..), Handler, Route (..), Widget) -import Yesod +import Yesod hiding ((==.), (=.), update) +import Database.Esqueleto.Experimental hiding ((<&>)) tickerAnnounceForm @@ -24,7 +26,10 @@ tickerAnnounceForm maybeCurrent = renderDivs $ TickerAnnouncement tickerWidget :: Handler Html tickerWidget = do - current <- runDB $ selectFirst [ TickerAnnouncementArchived ==. False ] [] + current <- runDB $ selectOne do + ann <- from (table @TickerAnnouncement) + where_ (ann ^. TickerAnnouncementArchived ==. val False) + pure ann (widget, enctype) <- generateFormPost (tickerAnnounceForm (current <&> entityVal)) @@ -40,13 +45,19 @@ tickerWidget = do postTickerAnnounceR :: Handler Html postTickerAnnounceR = do - current <- runDB $ selectFirst [ TickerAnnouncementArchived ==. False ] [] + current <- runDB $ selectOne do + ann <- from (table @TickerAnnouncement) + where_ (ann ^. TickerAnnouncementArchived ==. val False) + pure ann + ((result, widget), enctype) <- - runFormPost (tickerAnnounceForm (current <&> entityVal)) + runFormPost (tickerAnnounceForm (fmap entityVal current)) + case result of FormSuccess ann -> do - runDB $ do - updateWhere [] [ TickerAnnouncementArchived =. True ] + runDB do + update \t -> + set t [ TickerAnnouncementArchived =. val True ] insert ann redirect RootR _ -> defaultLayout @@ -59,5 +70,6 @@ postTickerAnnounceR = do postTickerDeleteR :: Handler Html postTickerDeleteR = do - runDB $ updateWhere [] [ TickerAnnouncementArchived =. True ] + runDB $ update \t -> + set t [TickerAnnouncementArchived =. val True] redirect RootR diff --git a/lib/Server/Frontend/Tickets.hs b/lib/Server/Frontend/Tickets.hs index 9b88a48..c542074 100644 --- a/lib/Server/Frontend/Tickets.hs +++ b/lib/Server/Frontend/Tickets.hs @@ -2,6 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE BlockArguments #-} module Server.Frontend.Tickets ( getTicketsR @@ -48,10 +49,14 @@ import Server.Frontend.SpaceTime (mkSpaceTimeDiagram, import Server.Frontend.Ticker (tickerWidget) import Server.Util (Service, secondsNow) import Text.Read (readMaybe) -import Yesod +import Yesod hiding ((==.), (||.), delete, update, (=.)) +import qualified Yesod import Yesod.Auth import Yesod.Auth.Uffd (UffdUser (..), uffdClient) +import Database.Esqueleto.Experimental hiding ((<&>), on) -- , on, delete, update, (=.)) +import qualified Database.Esqueleto.Experimental as E +import Database.Esqueleto.Experimental ((^.), (:&)(..), where_, orderBy, asc, associateJoin) getTicketsR :: Handler Html getTicketsR = do @@ -64,17 +69,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 +109,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 +155,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 +203,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 @TrainPing + where_ (trainping ^. TrainPingTicket ==. val (coerce ticketId)) + orderBy [desc (trainping ^. TrainPingTimestamp)] + 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 [ TrainPingTicket ==. coerce ticketId ] [Desc TrainPingTimestamp] + -- 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) @@ -235,7 +279,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) @@ -279,9 +323,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 +427,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 @@ -392,8 +441,11 @@ getTokenBlock :: Token -> Handler Html getTokenBlock token = do YesodRequest{..} <- getRequest let blocked = lookup "unblock" reqGetParams /= Just "true" - maybe <- runDB $ do - update (TrackerKey token) [ TrackerBlocked =. blocked ] + maybe <- runDB do + update \tracker -> do + set tracker [TrackerBlocked =. val blocked] + where_ (tracker ^. TrackerId ==. val (TrackerKey token)) + -- Yesod.update (TrackerKey token) [ TrackerBlocked Yesod.=. blocked ] get (TrackerKey token) case maybe of Just r@Tracker{..} -> do diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs index 5ad4b40..6ef6ed2 100644 --- a/lib/Server/GTFS_RT.hs +++ b/lib/Server/GTFS_RT.hs @@ -54,6 +54,7 @@ import qualified Proto.GtfsRealtime as RT import qualified Proto.GtfsRealtime_Fields as RT import Servant.API ((:<|>) (..)) import Server.Util (Service, secondsNow) +import Config (ServerConfig (..)) -- | formats a day in the "stupid" format used by gtfs realtime toStupidDate :: Day -> Text @@ -69,17 +70,22 @@ toStupidDate date = toStupidTime :: Num i => UTCTime -> i toStupidTime = fromIntegral . systemSeconds . utcToSystemTime -gtfsRealtimeServer :: GTFS -> Pool SqlBackend -> Service GtfsRealtimeAPI -gtfsRealtimeServer gtfs@GTFS{..} dbpool = +gtfsRealtimeServer :: ServerConfig -> GTFS -> Pool SqlBackend -> Service GtfsRealtimeAPI +gtfsRealtimeServer settings@ServerConfig{..} gtfs@GTFS{..} dbpool = handleServiceAlerts :<|> handleTripUpdates :<|> handleVehiclePositions + where - handleServiceAlerts = runSql dbpool $ do + + -- return an empty message if we're in silent mode & not force=yes + doNothingIfSilent m force = + if serverConfigBeSilent && not force then defFeedMessage mempty + else m >>= defFeedMessage + + handleServiceAlerts = doNothingIfSilent $ runSql dbpool $ do announcements <- selectList [] [] - alerts <- forM announcements $ \(Entity (AnnouncementKey uuid) announcement@Announcement{..}) -> do + forM announcements $ \(Entity (AnnouncementKey uuid) announcement@Announcement{..}) -> do ticket <- getJust announcementTicket pure $ mkAlert uuid announcement ticket - defFeedMessage alerts - where mkAlert :: UUID.UUID -> Announcement -> Ticket -> RT.FeedEntity mkAlert uuid Announcement{..} Ticket{..} = @@ -95,7 +101,7 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool = & RT.descriptionText .~ monolingual "de" announcementMessage ) - handleTripUpdates = runSql dbpool $ do + handleTripUpdates = doNothingIfSilent $ runSql dbpool $ do now <- liftIO getCurrentTime let today = utctDay now nowSeconds <- secondsNow today @@ -154,10 +160,9 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool = & RT.uncertainty .~ 60 ) & RT.scheduleRelationship .~ RT.TripUpdate'StopTimeUpdate'SCHEDULED + pure (catMaybes tripUpdates) - defFeedMessage (catMaybes tripUpdates) - - handleVehiclePositions = runSql dbpool $ do + handleVehiclePositions = doNothingIfSilent $ runSql dbpool $ do ticket <- selectList [TicketCompleted ==. False] [] @@ -168,7 +173,7 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool = -- Just lastPing -> -- pure (Just $ mkPosition (lastPing, ticket)) - defFeedMessage [] -- (catMaybes positions) + pure [] -- (catMaybes positions) where mkPosition :: (Entity TrainPing, Ticket) -> RT.FeedEntity diff --git a/lib/Server/Subscribe.hs b/lib/Server/Subscribe.hs index 831f4c9..8559659 100644 --- a/lib/Server/Subscribe.hs +++ b/lib/Server/Subscribe.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments#-} module Server.Subscribe where import Conduit (MonadIO (..)) @@ -13,15 +14,12 @@ import Data.Map (Map) import qualified Data.Map as M import Data.Pool import Data.UUID (UUID) -import Database.Persist (Entity (entityKey), SelectOpt (Desc), - entityVal, selectFirst, selectList, - (<-.), (==.), (||.)) import Database.Persist.Sql (SqlBackend) import qualified Network.WebSockets as WS import Persist import Server.Base (ServerState) import Server.Util (ServiceM) - +import Database.Esqueleto.Experimental hiding ((<&>)) handleSubscribe :: Pool SqlBackend @@ -38,8 +36,11 @@ handleSubscribe dbpool subscribers (ticketId :: UUID) conn = liftIO $ WS.withPin pure queue -- send most recent ping, if any (so we won't have to wait for movement) - runSqlWithoutLog dbpool - (selectFirst [TrainPingTicket ==. coerce ticketId] [Desc TrainPingTimestamp]) + runSqlWithoutLog dbpool (selectOne do + ping <- from (table @TrainPing) + where_ (ping ^. TrainPingTicket ==. val (coerce ticketId)) + orderBy [desc (ping ^. TrainPingTimestamp)] + pure ping) <&> fmap entityVal >>= flip whenJust (WS.sendTextData conn . A.encode) @@ -57,7 +58,19 @@ handleSubscribe dbpool subscribers (ticketId :: UUID) conn = liftIO $ WS.withPin -- getTicketTrackers :: (MonadLogger (t (ResourceT IO)), MonadIO (t (ResourceT IO))) -- => UUID -> ReaderT SqlBackend (t (ResourceT IO)) [Entity Tracker] -getTicketTrackers ticketId = do - joins <- selectList [TrackerTicketTicket ==. TicketKey ticketId] [] - <&> fmap (trackerTicketTracker . entityVal) - selectList ([TrackerId <-. joins] ||. [TrackerCurrentTicket ==. Just (TicketKey ticketId)]) [] +getTicketTrackers ticketId = select do + (tracker :& trackerticket) <- from $ + table @Tracker + `innerJoin` + table @TrackerTicket + `on` \(tr :& ti) -> tr ^. TrackerId ==. ti ^. TrackerTicketTracker + + where_ $ + tracker ^. TrackerCurrentTicket ==. val (Just (TicketKey ticketId)) + ||. trackerticket ^. TrackerTicketTicket ==. val (TicketKey ticketId) + + pure tracker + + -- joins <- selectList [TrackerTicketTicket ==. TicketKey ticketId] [] + -- <&> fmap (trackerTicketTracker . entityVal) + -- selectList ([TrackerId <-. joins] ||. [TrackerCurrentTicket ==. Just (TicketKey ticketId)]) [] |