Server: ingest owntracks messages, frontend tracker view

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 {
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|
+        <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