diff options
| -rw-r--r-- | README.md | 19 | ||||
| -rw-r--r-- | lib/API.hs | 12 | ||||
| -rw-r--r-- | lib/Server.hs | 21 | ||||
| -rw-r--r-- | lib/Server/Util.hs | 9 | ||||
| -rw-r--r-- | tracktrain.cabal | 3 |
5 files changed, 55 insertions, 9 deletions
@@ -8,9 +8,24 @@ in e.g. passenger information systems. Timetables are read in via GTFS. ## Server I run a test-deployment of this at (tracktrain.stuebinm.eu)[https://tracktrain.stuebinm.eu]. +### API It self-generates an OpenAPI description of the currently implemented routes at -(`/api`)[https://tracktrain.stuebinm.eu/debug/openapi]. - +(`/api/openapi`)[https://tracktrain.stuebinm.eu/debug/openapi]. + +### Metrics +It offers prometheus-compatible metrics under /metrics. Run the server with `+RTS -T` +to also get metrics on the ghc runtime system (via the [prometheus-metrics-ghc](https://hackage.haskell.org/package/prometheus-metrics-ghc-1.0.1.2/docs/Prometheus-Metric-GHC.html +)) +package. + +## Routes +The entire app is written as a single monolithic webserver, so you might want +to restrict access via a reverse-proxy: + - /api must be public (otherwise tracking won't work) + - /api/openapi is a self-description of the API endpoints + - /obu is the onboard-unit for tracking + - /metrics is a prometheus-compatible metrics endpoint + - everything else (including /) is part of the admin interface ## Packages & Modules @@ -5,7 +5,7 @@ -- | The sole authorative definition of this server's API, given as a Servant-style -- Haskell type. All other descriptions of the API are generated from this one. -module API (API, CompleteAPI, GtfsRealtimeAPI, RegisterJson(..)) where +module API (API, CompleteAPI, GtfsRealtimeAPI, RegisterJson(..), Metrics(..)) where import Data.Map (Map) import Data.Proxy (Proxy (..)) @@ -32,11 +32,14 @@ import Web.Internal.FormUrlEncoded (Form) import Control.Lens (At (at), (&), (?~)) import Data.Aeson (FromJSON (..), genericParseJSON) +import Data.ByteString.Lazy (ByteString) import Data.HashMap.Strict.InsOrd (singleton) import GHC.Generics (Generic) import GTFS import GTFS.Realtime.FeedEntity import GTFS.Realtime.FeedMessage (FeedMessage) +import Prometheus + import Persist newtype RegisterJson = RegisterJson @@ -76,9 +79,16 @@ type GtfsRealtimeAPI = "servicealerts" :> Get '[Proto] FeedMessage type CompleteAPI = "api" :> "openapi" :> Get '[JSON] Swagger :<|> "api" :> API + :<|> "metrics" :> Get '[PlainText] Text :<|> Raw -- hook for yesod frontend +data Metrics = Metrics + { metricsWSGauge :: Gauge } + + + + -- TODO write something useful here! (and if it's just "hey this is some websocket thingie") instance HasSwagger WebSocket where toSwagger _ = mempty diff --git a/lib/Server.hs b/lib/Server.hs index 93046f8..6ca9c14 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -12,6 +12,7 @@ -- Implementation of the API. This module is the main point of the program. module Server (application) where import Control.Monad (forever, unless, void, when) +import Control.Monad.Catch (handle) import Control.Monad.Extra (ifM, maybeM, unlessM, whenM) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Logger (LoggingT, logWarnN) @@ -26,6 +27,7 @@ import Data.Pool (Pool) import Data.Proxy (Proxy (Proxy)) import Data.Swagger (toSchema) import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) import Data.Time (NominalDiffTime, UTCTime (utctDay), addUTCTime, diffUTCTime, getCurrentTime, @@ -58,11 +60,17 @@ import System.IO.Unsafe import Config (ServerConfig) import Data.ByteString (ByteString) +import Data.ByteString.Lazy (toStrict) +import Prometheus +import Prometheus.Metric.GHC application :: GTFS -> Pool SqlBackend -> IO Application application gtfs dbpool = do doMigration dbpool - pure $ serve (Proxy @CompleteAPI) $ hoistServer (Proxy @CompleteAPI) runService $ server gtfs dbpool + metrics <- Metrics + <$> register (gauge (Info "ws_connections" "Number of WS Connections")) + register ghcMetrics + pure $ serve (Proxy @CompleteAPI) $ hoistServer (Proxy @CompleteAPI) runService $ server gtfs metrics dbpool -- databaseMigration :: ConnectionString -> IO () doMigration pool = runSql pool $ @@ -71,12 +79,12 @@ doMigration pool = runSql pool $ -- returns an empty list runMigration migrateAll -server :: GTFS -> Pool SqlBackend -> Service CompleteAPI -server gtfs@GTFS{..} dbpool = handleDebugAPI +server :: GTFS -> Metrics -> Pool SqlBackend -> Service CompleteAPI +server gtfs@GTFS{..} Metrics{..} dbpool = handleDebugAPI :<|> (handleStations :<|> handleTimetable :<|> handleTrip :<|> handleRegister :<|> handleTrainPing (throwError err401) :<|> handleWS :<|> handleDebugState :<|> handleDebugTrain :<|> handleDebugRegister - :<|> gtfsRealtimeServer gtfs dbpool) + :<|> gtfsRealtimeServer gtfs dbpool) :<|> metrics :<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom gtfs dbpool))) where handleStations = pure stations handleTimetable station maybeDay = do @@ -118,12 +126,14 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI pure (Just anchor) handleWS conn = do liftIO $ WS.forkPingThread conn 30 - forever $ do + incGauge metricsWSGauge + handle (\(e :: WS.ConnectionException) -> decGauge metricsWSGauge) $ forever $ do msg <- liftIO $ WS.receiveData conn case A.eitherDecode msg of Left err -> do logWarnN ("stray websocket message: "+|show msg|+" (could not decode: "+|err|+")") liftIO $ WS.sendClose conn (C8.pack err) + decGauge metricsWSGauge Right ping -> -- if invalid token, send a "polite" close request. Note that the client may -- ignore this and continue sending messages, which will continue to be handled. @@ -147,6 +157,7 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI selectList [TrainPingToken ==. token] [] <&> fmap entityVal pure (concat pings) handleDebugAPI = pure $ toSwagger (Proxy @API) + metrics = exportMetricsAsText <&> (decodeUtf8 . toStrict) -- TODO: proper debug logging for expired tokens diff --git a/lib/Server/Util.hs b/lib/Server/Util.hs index 4410711..41d26f7 100644 --- a/lib/Server/Util.hs +++ b/lib/Server/Util.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} -- | mostly the monad the service runs in module Server.Util (Service, ServiceM, runService, sendErrorMsg, secondsNow, utcToSeconds) where @@ -12,6 +14,7 @@ import Data.Time (Day, UTCTime (..), diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds) import GTFS (Seconds (..)) +import Prometheus (MonadMonitor (doIO)) import Servant (Handler, ServerError, ServerT, err404, errBody, errHeaders, throwError) @@ -21,6 +24,10 @@ type Service api = ServerT api ServiceM runService :: ServiceM a -> Handler a runService = runStderrLoggingT +instance MonadMonitor ServiceM where + doIO = liftIO + + sendErrorMsg :: Text -> ServiceM a sendErrorMsg msg = throwError err404 { errBody = A.encode $ A.object ["error" A..= (404 :: Int), "msg" A..= msg] } diff --git a/tracktrain.cabal b/tracktrain.cabal index d01cd9a..bb32447 100644 --- a/tracktrain.cabal +++ b/tracktrain.cabal @@ -107,6 +107,9 @@ library , timezone-series , conferer , conferer-warp + , prometheus-client + , prometheus-metrics-ghc + , exceptions hs-source-dirs: lib exposed-modules: GTFS , Server |