From 426ecb4e0ccc23e411039b7f075155df275b0a2d Mon Sep 17 00:00:00 2001 From: stuebinm Date: Thu, 16 Apr 2026 01:25:16 +0200 Subject: Server: ingest owntracks messages, frontend tracker view --- lib/API.hs | 6 ++- lib/Server.hs | 23 ++++++----- lib/Server/Frontend.hs | 1 + lib/Server/Frontend/Routes.hs | 2 + lib/Server/Frontend/Tracker.hs | 65 ++++++++++++++++++++++++++++++ lib/Server/Ingest.hs | 89 ++++++++++++++++++++++++++++++++++++------ 6 files changed, 164 insertions(+), 22 deletions(-) create mode 100644 lib/Server/Frontend/Tracker.hs (limited to 'lib') diff --git a/lib/API.hs b/lib/API.hs index 12d5ba6..3962f73 100644 --- a/lib/API.hs +++ b/lib/API.hs @@ -29,7 +29,7 @@ import Servant.API (Accept, Capture, Get, JSON, MimeRender, MimeUnrender, NoContent, OctetStream, PlainText, Post, QueryParam, Raw, ReqBody, - type (:<|>) (..)) + type (:<|>) (..), QueryFlag) import Servant.API.WebSocket (WebSocket) import Servant.Swagger (HasSwagger (..)) import Web.Internal.FormUrlEncoded (Form) @@ -51,6 +51,7 @@ import Persist import Prometheus import Proto.GtfsRealtime (FeedMessage) import Servant.API.ContentTypes (Accept (..)) +import qualified OwnTracks as OT -- | a bare ping as sent by a tracker device data SentPing = SentPing @@ -75,11 +76,14 @@ type API = :<|> "debug" :> "pings" :> Capture "Ticket Id" UUID :> Get '[JSON] [Ping] :<|> "gtfs.zip" :> Get '[OctetStream] GTFSFile :<|> "gtfs" :> GtfsRealtimeAPI + :<|> "owntracks" :> OwnTracksAPI type GtfsRealtimeAPI = "servicealerts" :> QueryFlag "force" :> Get '[Proto] FeedMessage :<|> "tripupdates" :> QueryFlag "force" :> Get '[Proto] FeedMessage :<|> "vehiclepositions" :> QueryFlag "force" :> Get '[Proto] FeedMessage +type OwnTracksAPI = + "pub" :> QueryParam "u" Text :> QueryParam "d" Text :> ReqBody '[JSON] OT.Message :> Post '[JSON] () type CompleteAPI = diff --git a/lib/Server.hs b/lib/Server.hs index 3fc2c5a..e418226 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -44,7 +44,8 @@ import Server.Base (ServerState) import Server.Frontend (Frontend (..)) import Server.GTFS_RT (gtfsRealtimeServer) import Server.Ingest (handleTrackerRegister, - handleTrainPing, handleWS) + handlePing, handleWS, + handleOwntracksMessage) 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/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/Routes.hs b/lib/Server/Frontend/Routes.hs index 75b1bda..fa3a9ce 100644 --- a/lib/Server/Frontend/Routes.hs +++ b/lib/Server/Frontend/Routes.hs @@ -45,6 +45,8 @@ mkYesodData "Frontend" [parseRoutes| /ticket/announce/#UUID AnnounceR POST /ticket/del-announce/#UUID DelAnnounceR GET +/tracker/#Text TrackerViewR GET + /ticker/announce TickerAnnounceR POST /ticker/delete TickerDeleteR POST diff --git a/lib/Server/Frontend/Tracker.hs b/lib/Server/Frontend/Tracker.hs new file mode 100644 index 0000000..23bbdb9 --- /dev/null +++ b/lib/Server/Frontend/Tracker.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE QuasiQuotes #-} + +module Server.Frontend.Tracker (getTrackerViewR) where +import Data.Coerce (coerce) +import Data.Functor ((<&>)) +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 + +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| +

_{MsgTracker name} + (#{trackerId}) +
+

_{MsgLastTrackerStatus} + $maybe Entity _ TrackerStatus{..} <- maybeStatus + LocationPermission: #{show $ statusLocationPermission trackerStatusStatus}
+ BatteryOptimisations: #{show $ statusBatteryOptimizations trackerStatusStatus}
+ Phone in power save mode: #{show $ statusPhonePowerSaveMode trackerStatusStatus} + $nothing + Status unknown +
+

_{MsgLastTrackerPosition} + $maybe Entity _ Ping{..} <- maybePing + Position: #{show pingGeopos}
+ Timestamp: #{show pingTimestamp}
+ $maybe ticketId <- pingTicket + Ticket: #{UUID.toText (coerce ticketId)} + $nothing + Ticket: (no assigned ticket) + $nothing + (none) + |] diff --git a/lib/Server/Ingest.hs b/lib/Server/Ingest.hs index 8ef8082..363088c 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 (..)) @@ -14,7 +14,8 @@ import Control.Monad.Extra (ifM, mapMaybeM, whenJust, whenJustM) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Logger (LoggingT, logInfoN, - logWarnN) + logErrorN, + logWarnN, logDebugN) import Control.Monad.Reader (ReaderT) import qualified Data.Aeson as A import qualified Data.ByteString.Char8 as C8 @@ -36,7 +37,7 @@ 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,7 +45,6 @@ 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) @@ -59,31 +59,34 @@ import GHC.Generics (Generic) import GTFS (seconds2Double) import Prometheus (decGauge, incGauge) import Server.Base (ServerState) - +import OwnTracks hiding (Ping) +import Database.Esqueleto.Experimental (selectOne, where_, (^.), table, from, val) +import qualified Database.Esqueleto.Experimental as E +import Data.Maybe (fromJust) 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 @@ -113,6 +116,70 @@ handleTrainPing dbpool subscribers cfg onError ping@SentPing{..} = 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 -- cgit v1.2.3