diff options
Diffstat (limited to 'lib/Server/Ingest.hs')
| -rw-r--r-- | lib/Server/Ingest.hs | 89 |
1 files changed, 78 insertions, 11 deletions
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 |