Haskell Instrumentation

Foundation.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
module Foundation
  (
    module Database.PostgreSQL.Simple
  , module Control.Monad.Reader
  , module Control.Monad.Trans
  , module Data.String.Conv
  , module Foundation
  , module Data.Int
  , module System.Log.FastLogger
  )
  where

import Database.PostgreSQL.Simple hiding (Query)
import Control.Monad.Reader
import Control.Monad.Trans
import Data.String.Conv
import Data.Int(Int64)
import Data.Text
import Network.Wai.Middleware.RequestLogger
import Network.Wai
import Data.Vault.Lazy as Vault
import InstrumentedCore
import InstrumentedScotty (ActionT, request, ScottyError)
import qualified Data.Vault.Lazy as Vault
import System.Log.FastLogger
import Control.Monad.Logger

data Env = EnvProd | EnvDev deriving (Show, Eq)


data AppConfig = AppConfig
  {
    configConnection :: Connection
  , configEnv :: Env
  , configPort :: Int
  , configLogger :: FastLogger
  }

type AppT = ReaderT AppConfig

class (Monad m, HasInstrumentation m) => HasConfig m where
  getConfig :: m AppConfig

class (MonadIO m, HasInstrumentation m) => HasDb m where
  getDb :: m Connection

instance (MonadIO m) => HasConfig (ReaderT AppConfig m) where
  getConfig = ask


instance (MonadIO m) => HasDb (ReaderT AppConfig m) where
  getDb = fmap configConnection getConfig

instance (ScottyError e, HasInstrumentation m) => HasInstrumentation (ActionT e m) where
  logInstrumentationData idata = lift $ logInstrumentationData idata

instance (MonadIO m) => MonadLogger (ReaderT AppConfig m) where
  monadLoggerLog loc logSource logLevel msg = do
    logger <- fmap configLogger getConfig
    liftIO $ logger $ defaultLogStr loc logSource logLevel (toLogStr msg)

instance (ScottyError e, MonadLogger m) => MonadLogger (ActionT e m) where
  monadLoggerLog loc logSource logLevel msg = lift $ monadLoggerLog loc logSource logLevel msg

instance (MonadIO m) => HasInstrumentation (ReaderT AppConfig m) where
  logInstrumentationData idata = do
    logger <- fmap configLogger getConfig
    liftIO $ logger $ toLogStr $ (show idata) ++ "\n"

InstrumentedScotty.hs

{-# LANGUAGE FlexibleContexts #-}

module InstrumentedScotty
  (
    module Web.Scotty.Trans
  , get
  , post
  , put
  , delete
  , patch
  , options
  , addroute
  )
where

import Web.Scotty.Trans hiding (get, post, put, delete, patch, options, addroute)
import qualified Web.Scotty.Trans as S
import InstrumentedCore
import Control.Monad.Trans.Class(lift)

instrumentedAction original action = original action_
  where
    action_ = do
      st <- liftIO $ getCurrentTime
      result <- action
      en <- liftIO $ getCurrentTime
      logInstrumentationData InstrumentationData{instrStart=st, instrEnd=en, instrPayload=Render}
      return result


get route action = instrumentedAction (S.get route) action
post route action = instrumentedAction (S.post route) action
put route action = instrumentedAction (S.put route) action
delete route action = instrumentedAction (S.delete route) action
patch route action = instrumentedAction (S.patch route) action
options route action = instrumentedAction (S.options route) action
addroute method route action = instrumentedAction (S.addroute method route) action

IntrumentedCore.hs

module InstrumentedCore
  (
    module Data.Time
  , module Data.Time.Clock
  , module InstrumentedCore
  , module Control.Monad.IO.Class
  )
where

import Data.Time(getCurrentTime, UTCTime)
import Data.Time.Clock(diffUTCTime)
import Control.Monad.IO.Class (liftIO, MonadIO)


data InstrumentationPayload =
  Sql (Maybe String)
  | Render

data InstrumentationData = InstrumentationData
  {
    instrStart :: UTCTime
  , instrEnd :: UTCTime
  , instrPayload :: InstrumentationPayload
  }

instance Show InstrumentationData where
  show x = "[" ++ (show diff) ++ "] " ++ (dataType $ instrPayload x)
    where
      diff = diffUTCTime (instrEnd x) (instrStart x)
      dataType (Sql x) = "SQL"
      dataType (Render) = "Render"

class (MonadIO m) => HasInstrumentation m where
  logInstrumentationData :: InstrumentationData -> m ()