aboutsummaryrefslogtreecommitdiff
path: root/lib/Server/Util.hs
blob: 01064283cf8ab4895ff2722d71899663c91df808 (plain)
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)