aboutsummaryrefslogtreecommitdiff
path: root/lib/Server
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Server')
-rw-r--r--lib/Server/Frontend.hs1
-rw-r--r--lib/Server/Frontend/Routes.hs2
-rw-r--r--lib/Server/Frontend/Tracker.hs65
-rw-r--r--lib/Server/Ingest.hs89
4 files changed, 146 insertions, 11 deletions
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|
+ <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/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
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-16 23:43:16 +0000