1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
|
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE RecordWildCards #-}
-- | mostly the monad the service runs in
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 (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 (ReaderT LoggingConfig Handler)
type Service api = ServerT api ServiceM
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
{ errBody = A.encode $ A.object ["error" A..= (404 :: Int), "msg" A..= msg] }
secondsNow :: MonadIO m => Day -> m Seconds
secondsNow runningDay = do
now <- liftIO getCurrentTime
pure $ utcToSeconds now runningDay
-- | convert utc time to seconds on a day, with wrap-around
-- for trains that cross midnight.
utcToSeconds :: UTCTime -> Day -> Seconds
utcToSeconds time day =
Seconds $ round $ nominalDiffTimeToSeconds $ diffUTCTime time (UTCTime day 0)
|
