restructure: get the tracker to work again

This should hopefully be the final (major) part of the restructuring: a
tracker no longer has to know which trip it is on (and indeed it has no
idea for now), instead the server keeps state about which trips are
currently running and will insert incoming pings in a hopefully
reasonable manner, based on their geoposition & time.

There's lots of associated TODO items here (especially there should be
manual overrides for all this logic in the web ui), but that's work for
a future me.

(incidentally, this also adds support for sending all log messages out
via ntfy-sh)

1 files changed, 44 insertions, 5 deletions

diff --git a/lib/Server/Util.hs b/lib/Server/Util.hs
index 5ffb829..0106428 100644
--- a/lib/Server/Util.hs
+++ b/lib/Server/Util.hs
@@ -1,28 +1,67 @@
+{-# LANGUAGE BlockArguments  #-}
+{-# LANGUAGE RecordWildCards #-}
 -- | mostly the monad the service runs in
-module Server.Util (Service, ServiceM, runService, sendErrorMsg, secondsNow, utcToSeconds) where
+module Server.Util (Service, ServiceM, runService, sendErrorMsg, secondsNow, utcToSeconds, runLogging) where
 
+import           Config                 (LoggingConfig (..))
+import           Control.Exception      (handle, try)
+import           Control.Monad.Extra    (void, whenJust)
 import           Control.Monad.IO.Class (MonadIO (liftIO))
-import           Control.Monad.Logger   (LoggingT, runStderrLoggingT)
+import           Control.Monad.Logger   (Loc, LogLevel (..), LogSource, LogStr,
+                                         LoggingT (..), defaultOutput,
+                                         fromLogStr, runStderrLoggingT)
+import           Control.Monad.Reader   (ReaderT (..))
 import qualified Data.Aeson             as A
 import           Data.ByteString        (ByteString)
+import qualified Data.ByteString        as C8
 import           Data.Text              (Text)
+import qualified Data.Text              as T
+import           Data.Text.Encoding     (decodeUtf8Lenient)
 import           Data.Time              (Day, UTCTime (..), diffUTCTime,
                                          getCurrentTime,
                                          nominalDiffTimeToSeconds)
+import           Fmt                    ((+|), (|+))
+import           GHC.IO.Exception       (IOException (IOError))
 import           GTFS                   (Seconds (..))
 import           Prometheus             (MonadMonitor (doIO))
 import           Servant                (Handler, ServerError, ServerT, err404,
                                          errBody, errHeaders, throwError)
+import           System.IO              (stderr)
+import           System.Process.Extra   (callProcess)
 
-type ServiceM  = LoggingT Handler
+type ServiceM  = LoggingT (ReaderT LoggingConfig Handler)
 type Service api = ServerT api ServiceM
 
-runService :: ServiceM a -> Handler a
-runService = runStderrLoggingT
+runService :: LoggingConfig -> ServiceM a -> Handler a
+runService conf m = runReaderT (runLogging conf m) conf
 
 instance MonadMonitor ServiceM where
   doIO = liftIO
 
+runLogging :: MonadIO m => LoggingConfig -> LoggingT m a -> m a
+runLogging LoggingConfig{..} logging = runLoggingT logging printLogMsg
+  where printLogMsg loc source level msg = do
+          -- this is what runStderrLoggingT does
+          defaultOutput stderr loc source level msg
+
+          whenJust loggingConfigNtfyToken \token -> handle ntfyFailed do
+            callProcess "ntfy"
+              [ "send"
+              , "--token=" <> T.unpack token
+              , "--title="+|loggingConfigHostname|+"/"+|"tracktrain"
+              , "--priority="+|show (ntfyPriority level)|+""
+              , T.unpack loggingConfigNtfyTopic
+              , T.unpack (decodeUtf8Lenient (fromLogStr msg)) ]
+
+        ntfyFailed (e :: IOError) =
+          putStrLn ("calling ntfy failed:"+|show e|+".")
+        ntfyPriority level = case level of
+          LevelDebug   -> 2
+          LevelInfo    -> 3
+          LevelWarn    -> 4
+          LevelError   -> 5
+          LevelOther _ -> 0
+
 
 sendErrorMsg :: Text -> ServiceM a
 sendErrorMsg msg = throwError err404