diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/Server.hs | 25 | ||||
| -rw-r--r-- | lib/Server/Base.hs | 4 | ||||
| -rw-r--r-- | lib/Server/Frontend.hs | 1 | ||||
| -rw-r--r-- | lib/Server/Frontend/OnboardUnit.hs | 28 | ||||
| -rw-r--r-- | lib/Server/Frontend/Routes.hs | 8 | ||||
| -rw-r--r-- | lib/Server/Frontend/Ticker.hs | 40 | ||||
| -rw-r--r-- | lib/Server/Frontend/Tickets.hs | 205 | ||||
| -rw-r--r-- | lib/Server/Frontend/Tracker.hs | 85 | ||||
| -rw-r--r-- | lib/Server/GTFS_RT.hs | 47 | ||||
| -rw-r--r-- | lib/Server/Ingest.hs | 134 | ||||
| -rw-r--r-- | lib/Server/Subscribe.hs | 66 |
11 files changed, 445 insertions, 198 deletions
diff --git a/lib/Server.hs b/lib/Server.hs index 3fc2c5a..4eb101d 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -43,8 +43,9 @@ import Servant.Swagger (toSwagger) import Server.Base (ServerState) import Server.Frontend (Frontend (..)) import Server.GTFS_RT (gtfsRealtimeServer) -import Server.Ingest (handleTrackerRegister, - handleTrainPing, handleWS) +import Server.Ingest (handleOwntracksMessage, + handlePing, handleTrackerRegister, + handleWS) import Server.Subscribe (handleSubscribe) import Server.Util (Service, runLogging, runService, serveDirectoryFileServer) @@ -78,14 +79,15 @@ server -> Pool SqlBackend -> ServerConfig -> Service CompleteAPI -server gtfs metrics@Metrics{..} subscribers dbpool settings = handleDebugAPI - :<|> (handleTrackerRegister dbpool - :<|> handleTrainPing dbpool subscribers settings (throwError err401) +server gtfs metrics@Metrics{..} subscribers dbpool settings = {- handleDebugAPI + :<|> -} (handleTrackerRegister dbpool + :<|> handlePing dbpool subscribers settings (throwError err401) :<|> handleWS dbpool subscribers settings metrics :<|> handleCurrentTicker :<|> handleSubscribe dbpool subscribers :<|> handleDebugState :<|> handleDebugTrain - :<|> pure (GTFS.gtfsFile gtfs) :<|> gtfsRealtimeServer gtfs dbpool) + :<|> pure (GTFS.gtfsFile gtfs) :<|> gtfsRealtimeServer settings gtfs dbpool + :<|> owntracksServer) :<|> handleMetrics :<|> serveDirectoryFileServer (serverConfigAssets settings) :<|> pure (unsafePerformIO (toWaiAppPlain (Frontend gtfs dbpool settings))) @@ -94,8 +96,8 @@ server gtfs metrics@Metrics{..} subscribers dbpool settings = handleDebugAPI now <- liftIO getCurrentTime runSql dbpool $ do tracker <- selectList [TrackerBlocked ==. False, TrackerExpires >=. now] [] - pairs <- forM tracker $ \(Entity token@(TrackerKey uuid) _) -> do - entities <- selectList [TrainPingToken ==. token] [] + pairs <- forM tracker $ \(Entity trackerId@(TrackerKey uuid) _) -> do + entities <- selectList [PingTrackerId ==. trackerId] [] pure (uuid, fmap entityVal entities) pure (M.fromList pairs) handleCurrentTicker = runSql dbpool $ do @@ -108,11 +110,12 @@ server gtfs metrics@Metrics{..} subscribers dbpool settings = handleDebugAPI ] handleDebugTrain ticketId = runSql dbpool $ do trackers <- getTicketTrackers ticketId - pings <- forM trackers $ \(Entity token _) -> do - selectList [TrainPingToken ==. token] [] <&> fmap entityVal + pings <- forM trackers $ \(Entity trackerId _) -> do + selectList [PingTrackerId ==. trackerId] [] <&> fmap entityVal pure (concat pings) - handleDebugAPI = pure $ toSwagger (Proxy @API) + -- handleDebugAPI = pure $ toSwagger (Proxy @API) handleMetrics = exportMetricsAsText <&> (decodeUtf8 . toStrict) + owntracksServer u d location = handleOwntracksMessage dbpool subscribers settings u d location getTicketTrackers :: (MonadLogger (t (ResourceT IO)), MonadIO (t (ResourceT IO))) => UUID -> ReaderT SqlBackend (t (ResourceT IO)) [Entity Tracker] diff --git a/lib/Server/Base.hs b/lib/Server/Base.hs index 14b77ca..17b5b4a 100644 --- a/lib/Server/Base.hs +++ b/lib/Server/Base.hs @@ -4,6 +4,6 @@ module Server.Base (ServerState) where import Control.Concurrent.STM (TQueue, TVar) import qualified Data.Map as M import Data.UUID (UUID) -import Persist (TrainPing) +import Persist (Ping) -type ServerState = TVar (M.Map UUID [TQueue (Maybe TrainPing)]) +type ServerState = TVar (M.Map UUID [TQueue (Maybe Ping)]) diff --git a/lib/Server/Frontend.hs b/lib/Server/Frontend.hs index a9c2f69..9742c3e 100644 --- a/lib/Server/Frontend.hs +++ b/lib/Server/Frontend.hs @@ -8,6 +8,7 @@ import Server.Frontend.Routes import Server.Frontend.SpaceTime import Server.Frontend.Ticker import Server.Frontend.Tickets +import Server.Frontend.Tracker import Yesod import Yesod.Auth diff --git a/lib/Server/Frontend/OnboardUnit.hs b/lib/Server/Frontend/OnboardUnit.hs index 6a8fe6e..967cb6c 100644 --- a/lib/Server/Frontend/OnboardUnit.hs +++ b/lib/Server/Frontend/OnboardUnit.hs @@ -28,7 +28,7 @@ getOnboardTrackerR = do defaultLayout [whamlet| <section> <h2>Tracker - <strong>Token:</strong> <span id="token"> + <strong>TrackerId:</strong> <span id="trackerId"> <section> <h2>Status <p id="status">_{MsgNone} @@ -44,7 +44,7 @@ getOnboardTrackerR = do defaultLayout [whamlet| <script> - var token = null; + var trackerId = null; let euclid = (a,b) => { let x = a[0]-b[0]; @@ -127,7 +127,7 @@ getOnboardTrackerR = do defaultLayout [whamlet| if (ws !== undefined && ws.readyState == 1) { ws.send(JSON.stringify({ - token: token, + trackerId: trackerId, geopos: [ geoloc.coords.latitude, geoloc.coords.longitude ], timestamp: (new Date()).toISOString() })); @@ -144,28 +144,28 @@ getOnboardTrackerR = do defaultLayout [whamlet| let urlparams = new URLSearchParams(window.location.search); - token = urlparams.get("token"); + trackerId = urlparams.get("trackerId"); - if (token === null) { - token = await (await fetch("/api/tracker/register/", { + if (trackerId === null) { + trackerId = await (await fetch("/api/tracker/register/", { method: "POST", body: JSON.stringify({agent: "tracktrain-website"}), headers: {"Content-Type": "application/json"} })).json(); - if (token.error) { - alert("could not obtain token: \n" + token.msg); - setStatus("_{MsgTokenFailed}"); + if (trackerId.error) { + alert("could not obtain trackerId: \n" + trackerId.msg); + setStatus("_{MsgTrackerIdFailed}"); } else { - console.log("got token"); - window.location.search = `?token=${token}`; + console.log("got trackerId"); + window.location.search = `?trackerId=${trackerId}`; } } - console.log(token) + console.log(trackerId) - if (token !== null) { - document.getElementById("token").innerText = token; + if (trackerId !== null) { + document.getElementById("trackerId").innerText = trackerId; openWebsocket(); } } diff --git a/lib/Server/Frontend/Routes.hs b/lib/Server/Frontend/Routes.hs index 9245e6a..cf6e342 100644 --- a/lib/Server/Frontend/Routes.hs +++ b/lib/Server/Frontend/Routes.hs @@ -19,7 +19,7 @@ import Data.Time.Calendar (Day) import Data.UUID (UUID) import Database.Persist.Sql (SqlBackend, runSqlPool) import qualified GTFS -import Persist (Token) +import Persist (TrackerId) import Text.Blaze.Internal (MarkupM (Empty)) import Yesod import Yesod.Auth @@ -45,12 +45,15 @@ mkYesodData "Frontend" [parseRoutes| /ticket/announce/#UUID AnnounceR POST /ticket/del-announce/#UUID DelAnnounceR GET +/trackers TrackersR GET +/tracker/#Text TrackerViewR GET + /ticker/announce TickerAnnounceR POST /ticker/delete TickerDeleteR POST /spacetime SpaceTimeDiagramR GET -/token/block/#Token TokenBlock GET +/trackerId/block/#TrackerId TrackerIdBlock GET /gtfs/trips GtfsTripsViewR GET /gtfs/trip/#GTFS.TripId GtfsTripViewR GET @@ -149,3 +152,4 @@ instance YesodAuth Frontend where redirect ("/auth/page/uffd/forward" :: Text) onLogout = do clearSession + diff --git a/lib/Server/Frontend/Ticker.hs b/lib/Server/Frontend/Ticker.hs index 861197a..8813200 100644 --- a/lib/Server/Frontend/Ticker.hs +++ b/lib/Server/Frontend/Ticker.hs @@ -1,13 +1,15 @@ -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE QuasiQuotes #-} module Server.Frontend.Ticker (tickerWidget, postTickerAnnounceR, postTickerDeleteR) where -import Data.Functor ((<&>)) -import Data.Time (getCurrentTime) -import Persist (EntityField (TickerAnnouncementArchived), - TickerAnnouncement (..)) -import Server.Frontend.Routes (FrontendMessage (..), Handler, - Route (..), Widget) -import Yesod +import Data.Functor ((<&>)) +import Data.Time (getCurrentTime) +import Database.Esqueleto.Experimental hiding ((<&>)) +import Persist (EntityField (TickerAnnouncementArchived), + TickerAnnouncement (..)) +import Server.Frontend.Routes (FrontendMessage (..), Handler, + Route (..), Widget) +import Yesod hiding (update, (=.), (==.)) 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..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 diff --git a/lib/Server/Frontend/Tracker.hs b/lib/Server/Frontend/Tracker.hs new file mode 100644 index 0000000..e3d88ba --- /dev/null +++ b/lib/Server/Frontend/Tracker.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE QuasiQuotes #-} + +module Server.Frontend.Tracker (getTrackerViewR, getTrackersR) where +import Data.Coerce (coerce) +import Data.Function ((&)) +import Data.Functor ((<&>)) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (getCurrentTime) +import qualified Data.UUID as UUID +import Database.Esqueleto.Experimental hiding ((<&>)) +import Persist +import Server.Frontend.Routes (FrontendMessage (..), Handler, + Route (..), Widget) +import Yesod hiding (update, (=.), (==.)) + +import OwnTracks.Status + + +getTrackersR :: Handler Html +getTrackersR = do + trackers <- runDB $ select do + (t :& p) <- from $ + (table @Tracker) `LeftOuterJoin` (table @Ping) + `on` \(t :& p) -> just (t ^. TrackerId) ==. p ?. PingTrackerId + pure (t, p) + & fmap associateJoin + + defaultLayout [whamlet| + <h1> Trackers + <section> + <ul> + $forall (trackerId, (Tracker{..}, status)) <- M.toList trackers + <li><a href="@{TrackerViewR trackerName}">#{trackerName}</a> + |] + +getTrackerViewR :: Text -> Handler Html +getTrackerViewR name = + runDB (selectOne do + tracker <- from (table @Tracker) + where_ (tracker ^. TrackerName ==. val name) + pure tracker) + >>= \case + Nothing -> notFound + Just (Entity trackerId Tracker{..}) -> do + + (maybeStatus, maybePing) <- runDB $ do + status <- selectOne do + status <- from (table @TrackerStatus) + where_ (status ^. TrackerStatusTracker ==. val trackerId) + orderBy [desc $ status ^. TrackerStatusTimestamp] + pure status + ping <- selectOne do + ping <- from (table @Ping) + where_ (ping ^. PingTrackerId ==. val trackerId) + orderBy [desc $ ping ^. PingTimestamp] + pure ping + pure (status, ping) + + -- TODO: leaflet map; auto updates? + defaultLayout [whamlet| + <h1> _{MsgTracker name} + <em> (#{trackerId}) + <section> + <h2> _{MsgLastTrackerStatus} + $maybe Entity _ TrackerStatus{..} <- maybeStatus + LocationPermission: #{show $ statusLocationPermission trackerStatusStatus} <br> + BatteryOptimisations: #{show $ statusBatteryOptimizations trackerStatusStatus} <br> + Phone in power save mode: #{show $ statusPhonePowerSaveMode trackerStatusStatus} + $nothing + <em>Status unknown + <section> + <h2> _{MsgLastTrackerPosition} + $maybe Entity _ Ping{..} <- maybePing + Position: #{show pingGeopos} <br> + Timestamp: #{show pingTimestamp} <br> + $maybe ticketId <- pingTicket + Ticket: <a href="@{TicketViewR (coerce ticketId)}">#{UUID.toText (coerce ticketId)}</a> + $nothing + Ticket: (no assigned ticket) + $nothing + (none) + |] diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs index 5ad4b40..4b16a5b 100644 --- a/lib/Server/GTFS_RT.hs +++ b/lib/Server/GTFS_RT.hs @@ -8,6 +8,7 @@ module Server.GTFS_RT (gtfsRealtimeServer) where import API (GtfsRealtimeAPI) +import Config (ServerConfig (..)) import Control.Lens ((&), (.~)) import Control.Monad (forM) import Control.Monad.Extra (mapMaybeM) @@ -45,10 +46,10 @@ import GTFS (Depth (..), GTFS (..), toSeconds, toUTC, tripsOnDay) import Persist (Announcement (..), EntityField (..), Key (..), - Station (..), Stop (..), - Ticket (..), Token (..), - Tracker (..), TrainAnchor (..), - TrainPing (..), latitude, + Ping (..), Station (..), + Stop (..), Ticket (..), + Tracker (..), TrackerId (..), + TrainAnchor (..), latitude, longitude, runSql) import qualified Proto.GtfsRealtime as RT import qualified Proto.GtfsRealtime_Fields as RT @@ -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,25 +160,24 @@ 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] [] -- TODO: reimplement this (since trainpings no longer reference tickets it's gone for now) -- positions <- forM ticket $ \(Entity key ticket) -> do - -- selectFirst [TrainPingTicket ==. key] [Desc TrainPingTimestamp] >>= \case + -- selectFirst [PingTicket ==. key] [Desc PingTimestamp] >>= \case -- Nothing -> pure Nothing -- Just lastPing -> -- pure (Just $ mkPosition (lastPing, ticket)) - defFeedMessage [] -- (catMaybes positions) + pure [] -- (catMaybes positions) where - mkPosition :: (Entity TrainPing, Ticket) -> RT.FeedEntity - mkPosition (Entity key TrainPing{..}, Ticket{..}) = defMessage + mkPosition :: (Entity Ping, Ticket) -> RT.FeedEntity + mkPosition (Entity key Ping{..}, Ticket{..}) = defMessage & RT.id .~ T.pack (show key) & RT.vehicle .~ (defMessage & RT.trip .~ defTripDescriptor ticketTripName Nothing Nothing @@ -181,11 +186,11 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool = Just trainset -> Just $ defMessage & RT.label .~ trainset & RT.position .~ (defMessage - & RT.latitude .~ double2Float (latitude trainPingGeopos) - & RT.longitude .~ double2Float (longitude trainPingGeopos) + & RT.latitude .~ double2Float (latitude pingGeopos) + & RT.longitude .~ double2Float (longitude pingGeopos) ) -- TODO: should probably give currentStopSequence/stopId here as well - & RT.timestamp .~ toStupidTime trainPingTimestamp + & RT.timestamp .~ toStupidTime pingTimestamp ) diff --git a/lib/Server/Ingest.hs b/lib/Server/Ingest.hs index 959a4c6..8e122a7 100644 --- a/lib/Server/Ingest.hs +++ b/lib/Server/Ingest.hs @@ -1,7 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} -module Server.Ingest (handleTrackerRegister, handleTrainPing, handleWS) where +module Server.Ingest (handleTrackerRegister, handlePing, handleWS, handleOwntracksMessage) where import API (Metrics (..), RegisterJson (..), SentPing (..)) @@ -13,7 +13,8 @@ import Control.Monad.Catch (handle) import Control.Monad.Extra (ifM, mapMaybeM, whenJust, whenJustM) import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Logger (LoggingT, logInfoN, +import Control.Monad.Logger (LoggingT, logDebugN, + logErrorN, logInfoN, logWarnN) import Control.Monad.Reader (ReaderT) import qualified Data.Aeson as A @@ -36,7 +37,8 @@ import Fmt ((+|), (|+)) import qualified GTFS import qualified Network.WebSockets as WS import Persist -import Servant (err400, throwError) +import Servant (err400, err401, + throwError) import Servant.Server (Handler) import Server.Util (ServiceM, getTzseries, utcToSeconds) @@ -44,46 +46,49 @@ import Server.Util (ServiceM, getTzseries, import Config (LoggingConfig, ServerConfig (..)) import Control.Exception (throw) -import Control.Monad.Logger.CallStack (logErrorN) import Data.ByteString (ByteString) import Data.ByteString.Lazy (toStrict) import Data.Foldable (find, minimumBy) import Data.Function (on, (&)) +import Data.Maybe (fromJust) import qualified Data.Text as T import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries) import qualified Data.UUID as UUID +import Database.Esqueleto.Experimental (from, selectOne, table, + val, where_, (^.)) +import qualified Database.Esqueleto.Experimental as E import Extrapolation (Extrapolator (..), LinearExtrapolator (..), euclid) import GHC.Generics (Generic) import GTFS (seconds2Double) +import OwnTracks hiding (Ping) import Prometheus (decGauge, incGauge) import Server.Base (ServerState) - handleTrackerRegister :: Pool SqlBackend -> RegisterJson - -> ServiceM Token + -> ServiceM TrackerId handleTrackerRegister dbpool RegisterJson{..} = do today <- liftIO getCurrentTime <&> utctDay expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod runSql dbpool $ do - TrackerKey tracker <- insert (Tracker expires False registerAgent Nothing) - pure tracker + TrackerKey tracker <- insert (Tracker "dummy" expires False registerAgent Nothing) + pure (coerce tracker) where validityPeriod :: NominalDiffTime validityPeriod = nominalDay -handleTrainPing +handlePing :: Pool SqlBackend -> ServerState -> ServerConfig -> LoggingT (ReaderT LoggingConfig Handler) a -> SentPing -> LoggingT (ReaderT LoggingConfig Handler) (Maybe TrainAnchor) -handleTrainPing dbpool subscribers cfg onError ping@SentPing{..} = - isTokenValid dbpool sentPingToken >>= \case +handlePing dbpool subscribers cfg onError ping@SentPing{..} = + isTrackerIdValid dbpool sentPingTrackerId >>= \case Nothing -> onError >> pure Nothing Just tracker@Tracker{..} -> do @@ -107,13 +112,76 @@ handleTrainPing dbpool subscribers cfg onError ping@SentPing{..} = Nothing -> runSql dbpool (guessTicketFromPing cfg ping) >>= \case Just ticketId -> pure ticketId Nothing -> do - logWarnN $ "Tracker "+|UUID.toString (coerce sentPingToken)|+ + logWarnN $ "Tracker "+|UUID.toString (coerce sentPingTrackerId)|+ " sent a ping, but no trips are running today." throwError err400 - runSql dbpool $ insertSentPing subscribers cfg ping tracker ticketId + +handleOwntracksMessage + :: Pool SqlBackend + -> ServerState + -> ServerConfig + -> Maybe Text + -> Maybe Text + -> Message + -> LoggingT (ReaderT LoggingConfig Handler) () +handleOwntracksMessage dbpool subscribers cfg maybeUser device msg = do + user <- case maybeUser of + Just user -> pure user + Nothing -> throwError err401 + + -- TODO: maybe get the basic json here, and put it into a log-msg table? + + logDebugN $ "received msg: "+|show msg|+"." + + Entity trackerId tracker@Tracker{..} <- runSql dbpool $ (selectOne do + tracker <- from (table @Tracker) + where_ (tracker ^. TrackerName E.==. val user) + pure tracker) + >>= \case + Just tracker -> pure tracker + Nothing -> throw err401 + + case msg of + MsgStatus status -> do + now <- liftIO getCurrentTime + logInfoN $ "received status msg: "+|show status|+"" + runSql dbpool $ insert_ $ TrackerStatus trackerId now status + MsgLocation Location{..} -> do + let ping = SentPing + { sentPingTrackerId = trackerId + , sentPingGeopos = Geopos (locationLatitude, locationLongitude) + , sentPingTimestamp = locationTimestamp + } + + maybeTicketId <- case trackerCurrentTicket of + -- if the tracker is not associated with a ticket, it is probably new + -- & should be auto-associated with the most fitting current ticket + Nothing -> runSql dbpool (guessTicketFromPing cfg ping) >>= \case + Just ticketId -> pure (Just ticketId) + Nothing -> do + -- unfortunately, cannot really communicate anything useful back? + logWarnN $ "Owntracks user "+|user|+ + " sent a ping, but no trips are running today." + pure Nothing + + case maybeTicketId of + Nothing -> do + runSql dbpool $ insert $ Ping + { pingTicket = Nothing + , pingTrackerId = trackerId + , pingGeopos = Geopos (locationLatitude, locationLongitude) + , pingTimestamp = locationTimestamp + , pingSequence = Nothing + } + pure () + Just ticketId -> do + runSql dbpool $ insertSentPing subscribers cfg undefined tracker ticketId + pure () + + insertSentPing :: ServerState -> ServerConfig @@ -140,9 +208,9 @@ insertSentPing subscribers cfg ping@SentPing{..} tracker@Tracker{..} ticketId = maybeReassign <- selectFirst - [ TrainPingTicket ==. ticketId ] - [ Desc TrainPingTimestamp ] - <&> find (\ping -> trainPingSequence (entityVal ping) > trainAnchorSequence anchor) + [ PingTicket ==. Just ticketId, PingSequence !=. Nothing ] + [ Desc PingTimestamp ] + <&> find (\ping -> fromJust (pingSequence (entityVal ping)) > trainAnchorSequence anchor) >> guessTicketFromPing cfg ping <&> find (/= ticketId) @@ -154,19 +222,19 @@ insertSentPing subscribers cfg ping@SentPing{..} tracker@Tracker{..} ticketId = case maybeReassign of Just newTicketId -> do - update sentPingToken + update sentPingTrackerId [TrackerCurrentTicket =. Just newTicketId ] - logInfoN $ "tracker "+|UUID.toText (coerce sentPingToken)|+ + logInfoN $ "tracker "+|UUID.toText (coerce sentPingTrackerId)|+ "has switched direction, and was reassigned to ticket " +|UUID.toText (coerce newTicketId)|+"." insertSentPing subscribers cfg ping tracker newTicketId Nothing -> do - let trackedPing = TrainPing - { trainPingToken = sentPingToken - , trainPingGeopos = sentPingGeopos - , trainPingTimestamp = sentPingTimestamp - , trainPingSequence = trainAnchorSequence anchor - , trainPingTicket = ticketId + let trackedPing = Ping + { pingTrackerId = sentPingTrackerId + , pingGeopos = sentPingGeopos + , pingTimestamp = sentPingTimestamp + , pingSequence = Just (trainAnchorSequence anchor) + , pingTicket = Just ticketId } insert trackedPing @@ -182,11 +250,11 @@ insertSentPing subscribers cfg ping@SentPing{..} tracker@Tracker{..} ticketId = & (\(stop, _, _) -> stopSequence stop) & fromIntegral when (trainAnchorSequence anchor + 0.1 >= maxSequence) $ do - update sentPingToken + update sentPingTrackerId [TrackerCurrentTicket =. Nothing] update ticketId [TicketCompleted =. True] - logInfoN $ "Tracker "+|UUID.toString (coerce sentPingToken)|+ + logInfoN $ "Tracker "+|UUID.toString (coerce sentPingTrackerId)|+ " has completed ticket "+|UUID.toString (coerce ticketId)|+ " (trip "+|ticketTripName|+")" @@ -214,9 +282,9 @@ handleWS dbpool subscribers cfg Metrics{..} conn = do liftIO $ WS.sendClose conn (C8.pack err) -- TODO: send a close msg (Nothing) to the subscribed queues? decGauge metricsWSGauge Right ping -> do - -- if invalid token, send a "polite" close request. Note that the client may + -- if invalid trackerId, send a "polite" close request. Note that the client may -- ignore this and continue sending messages, which will continue to be handled. - handleTrainPing dbpool subscribers cfg (liftIO $ WS.sendClose conn ("" :: ByteString)) ping >>= \case + handlePing dbpool subscribers cfg (liftIO $ WS.sendClose conn ("" :: ByteString)) ping >>= \case Just anchor -> liftIO $ WS.sendTextData conn (A.encode anchor) Nothing -> pure () @@ -245,11 +313,11 @@ guessTicketFromPing cfg SentPing{..} = do in smallestDistance)) logInfoN - $ "Tracker "+|UUID.toString (coerce sentPingToken)|+ + $ "Tracker "+|UUID.toString (coerce sentPingTrackerId)|+ " is now handling ticket "+|UUID.toString (coerce (entityKey closestTicket))|+ " (trip "+|ticketTripName (entityVal closestTicket)|+")." - update sentPingToken + update sentPingTrackerId [TrackerCurrentTicket =. Just (entityKey closestTicket)] pure (Just (entityKey closestTicket)) @@ -260,9 +328,9 @@ spaceAndTimeDiff (pos1, time1) (pos2, time2) = where spaceDistance = euclid pos1 pos2 timeDiff = time1 - time2 --- TODO: proper debug logging for expired tokens -isTokenValid :: Pool SqlBackend -> TrackerId -> ServiceM (Maybe Tracker) -isTokenValid dbpool token = runSql dbpool $ get token >>= \case +-- TODO: proper debug logging for expired trackerIds +isTrackerIdValid :: Pool SqlBackend -> TrackerId -> ServiceM (Maybe Tracker) +isTrackerIdValid dbpool trackerId = runSql dbpool $ get trackerId >>= \case Just tracker | not (trackerBlocked tracker) -> do ifM (hasExpired (trackerExpires tracker)) (pure Nothing) diff --git a/lib/Server/Subscribe.hs b/lib/Server/Subscribe.hs index 831f4c9..86b67a6 100644 --- a/lib/Server/Subscribe.hs +++ b/lib/Server/Subscribe.hs @@ -1,27 +1,26 @@ +{-# LANGUAGE BlockArguments #-} module Server.Subscribe where -import Conduit (MonadIO (..)) -import Control.Concurrent.STM (atomically, newTQueue, readTQueue, - readTVar, writeTVar) -import Control.Exception (handle) -import Control.Monad.Extra (forever, whenJust) -import qualified Data.Aeson as A -import qualified Data.ByteString.Char8 as C8 -import Data.Coerce (coerce) -import Data.Functor ((<&>)) -import Data.Map (Map) -import qualified Data.Map as M +import Conduit (MonadIO (..)) +import Control.Concurrent.STM (atomically, newTQueue, + readTQueue, readTVar, + writeTVar) +import Control.Exception (handle) +import Control.Monad.Extra (forever, whenJust) +import qualified Data.Aeson as A +import qualified Data.ByteString.Char8 as C8 +import Data.Coerce (coerce) +import Data.Functor ((<&>)) +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 Data.UUID (UUID) +import Database.Esqueleto.Experimental hiding ((<&>)) +import Database.Persist.Sql (SqlBackend) +import qualified Network.WebSockets as WS import Persist -import Server.Base (ServerState) -import Server.Util (ServiceM) - +import Server.Base (ServerState) +import Server.Util (ServiceM) handleSubscribe :: Pool SqlBackend @@ -38,8 +37,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 @Ping) + where_ (ping ^. PingTicket ==. val (Just (coerce ticketId))) + orderBy [desc (ping ^. PingTimestamp)] + pure ping) <&> fmap entityVal >>= flip whenJust (WS.sendTextData conn . A.encode) @@ -57,7 +59,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)]) [] |