paul/yore
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Log service time

Browse Source
This commit is contained in:
Paul Brinkmeier 2025-10-06 08:52:39 +02:00
parent 72ffa08e18
commit e9934276d5
1 changed files with 30 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
app/Main.hs
View File

@ -17,10 +17,10 @@ import Control.Monad.Trans.Except (ExceptT (..), catchE, runExceptT)
import Data.Bifunctor (Bifunctor (..)) import Data.Bifunctor (Bifunctor (..))
import Data.Proxy (Proxy (..)) import Data.Proxy (Proxy (..))
import Data.Text (Text) import Data.Text (Text)
import Data.Time (Day, LocalTime (..), TimeOfDay (..), ZonedTime (..), addDays, toGregorian) import Data.Time (Day, LocalTime (..), TimeOfDay (..), ZonedTime (..), addDays, nominalDiffTimeToSeconds, toGregorian)
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Network.HTTP.Types (Status (..)) import Network.HTTP.Types (Status (..))
import Network.Wai (Request (..)) import Network.Wai (Middleware, Request (..), responseStatus)
import Servant import Servant
( Capture ( Capture
, Get , Get
@ -60,6 +60,8 @@ import Yore.Scrape (Issue (..), getIssuesByDay)
import Yore.Servant (GetSendfile, HTML, Sendfile (..)) import Yore.Servant (GetSendfile, HTML, Sendfile (..))
import Yore.Time (addYears, getCurrentDay, getSecondsUntilMidnight) import Yore.Time (addYears, getCurrentDay, getSecondsUntilMidnight)
import Data.Fixed (Pico)
import Data.Time.Clock.POSIX (getPOSIXTime)
import qualified Envy import qualified Envy
import qualified Yore.DB as DB import qualified Yore.DB as DB
import qualified Yore.Log as Log import qualified Yore.Log as Log
@ -112,24 +114,29 @@ doIndex cfg db =
runServer :: Config -> DB -> IO () runServer :: Config -> DB -> IO ()
runServer cfg db = runServer cfg db =
Warp.runSettings settings $ serve (Proxy @API) $ hoistServer (Proxy @API) nt $ server cfg db Warp.runSettings settings $ loggerMiddleware $ serve (Proxy @API) $ hoistServer (Proxy @API) nt $ server cfg db
where where
settings = settings =
foldr foldr
($) ($)
Warp.defaultSettings Warp.defaultSettings
[ Warp.setLogger logger [ Warp.setPort cfg.yorePort
, Warp.setPort cfg.yorePort
, Warp.setBeforeMainLoop $ Log.info $ printf "listening on port %d" cfg.yorePort , Warp.setBeforeMainLoop $ Log.info $ printf "listening on port %d" cfg.yorePort
, Warp.setOnException onException , Warp.setOnException onException
] ]
logger req status _ = do logger :: Request -> Status -> Pico -> IO ()
Log.info $ logger req status s = do
printf Log.info $ printf "%d %s %ss" (statusCode status) (requestLine req) (formatMetric s)
"%d %s"
(statusCode status) loggerMiddleware :: Middleware
(requestLine req) loggerMiddleware app req respond = do
begin <- getPOSIXTime
app req $ \res -> do
rr <- respond res
end <- getPOSIXTime
logger req (responseStatus res) (nominalDiffTimeToSeconds (end - begin))
pure rr
onException mbReq ex = do onException mbReq ex = do
Log.error $ printf "unhandled exception%s: %s%s" (maybe "" ((" in " ++) . requestLine) mbReq) (show ex) Log.error $ printf "unhandled exception%s: %s%s" (maybe "" ((" in " ++) . requestLine) mbReq) (show ex)
@ -141,6 +148,18 @@ runServer cfg db =
(BS8.unpack $ requestMethod req) (BS8.unpack $ requestMethod req)
(BS8.unpack $ rawPathInfo req <> rawQueryString req) (BS8.unpack $ rawPathInfo req <> rawQueryString req)
formatMetric :: Pico -> String
formatMetric x = go (-9) prefixes
where
prefixes = ["p", "n", "u", "m", "", "k", "M", "G"]
go :: Int -> [String] -> String
go _ [] = show x
go e (p : ps)
| x < 10 ^^ e =
show @Int (floor $ x * 10 ^^ (-e + 3)) ++ p
| otherwise = go (e + 3) ps
nt :: ExceptT Error IO a -> Handler a nt :: ExceptT Error IO a -> Handler a
nt action = MkHandler $ do nt action = MkHandler $ do
res <- runExceptT action res <- runExceptT action