diff options
| -rw-r--r-- | assets/style.css | 1 | ||||
| -rw-r--r-- | lib/API.hs | 6 | ||||
| -rw-r--r-- | lib/Server.hs | 23 | ||||
| -rw-r--r-- | lib/Server/Frontend.hs | 1 | ||||
| -rw-r--r-- | lib/Server/Frontend/Routes.hs | 2 | ||||
| -rw-r--r-- | lib/Server/Frontend/Tracker.hs | 65 | ||||
| -rw-r--r-- | lib/Server/Ingest.hs | 89 | ||||
| -rw-r--r-- | messages/de.msg | 14 | ||||
| -rw-r--r-- | messages/en.msg | 17 | ||||
| -rw-r--r-- | tracktrain.cabal | 1 |
10 files changed, 182 insertions, 37 deletions
diff --git a/assets/style.css b/assets/style.css index 6a3552f..315675d 100644 --- a/assets/style.css +++ b/assets/style.css @@ -5,7 +5,6 @@ section { border: 0.1rem solid black; padding: 1rem; margin: 2vw; - margin-top: 0; padding-top: 0; } body { @@ -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| + <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 diff --git a/messages/de.msg b/messages/de.msg index f3748df..aab2766 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -19,17 +19,17 @@ Info: Info SwitchLanguage: Sprache wechseln Switch: wechseln Stops: Stationen -Tokens: Token -BlockToken: blockieren -UnblockToken: zulassen -Token: Token +TrackerIds: TrackerId +BlockTrackerId: blockieren +UnblockTrackerId: zulassen +TrackerId: TrackerId Status: Status Expires: läuft ab Agent: Gerät Live: Echtzeit LastPing: Letzte Meldung -TrainPing lat long time: #{lat},#{long}, um #{time} -NoTrainPing: keine empfangen +Ping lat long time: #{lat},#{long}, um #{time} +NoPing: keine empfangen raw: roh EstimatedDelay: Geschätzte Verspätung OnStationSequence idx: an Stationsindex #{idx} @@ -45,7 +45,7 @@ incident: Aktuelle Störungsmeldung OBU: Onboard-Unit ChooseTrain: Fahrt auswählen -TokenFailed: konnte kein Token erhalten +TrackerIdFailed: konnte kein TrackerId erhalten PermissionFailed: Berechtigungsfehler WebsocketError: Websocketfehler Error: Fehler diff --git a/messages/en.msg b/messages/en.msg index c20149a..b093c28 100644 --- a/messages/en.msg +++ b/messages/en.msg @@ -19,17 +19,20 @@ Info: Info SwitchLanguage: Switch language to: Switch: Switch Stops: Stops -Tokens: Tokens -BlockToken: block -UnblockToken: unblock -Token: Token +TrackerIds: TrackerIds +BlockTrackerId: block +UnblockTrackerId: unblock +TrackerId: TrackerId +Tracker name@Text: Tracker #{name} +LastTrackerStatus: Last Status +LastTrackerPosition: Last Position Status: Status Expires: Expires Agent: Agent Live: Live LastPing: Last Ping -TrainPing lat@Double long@Double time@UTCTime: #{lat},#{long}, at #{time} -NoTrainPing: none received +Ping lat@Double long@Double time@UTCTime: #{lat},#{long}, at #{time} +NoPing: none received raw: raw EstimatedDelay: Estimated Delay OnStationSequence idx@String: on station index #{idx} @@ -46,7 +49,7 @@ incident: Current Incident text OBU: Onboard-Unit ChooseTrain: Choose a Train -TokenFailed: Failed to acquire token +TrackerIdFailed: Failed to acquire token PermissionFailed: permission failed WebsocketError: Websocket Error Error: Error diff --git a/tracktrain.cabal b/tracktrain.cabal index 6d6047f..16ccb98 100644 --- a/tracktrain.cabal +++ b/tracktrain.cabal @@ -123,6 +123,7 @@ library , Server.Frontend.Gtfs , Server.Frontend.SpaceTime , Server.Frontend.Ticker + , Server.Frontend.Tracker , OwnTracks , OwnTracks.Location , OwnTracks.Status |