mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-16 18:42:30 +03:00
349 lines
11 KiB
Haskell
349 lines
11 KiB
Haskell
-- This is taken from wai-logger and customised for our use
|
|
|
|
module Hasura.Server.Logging
|
|
( StartupLog(..)
|
|
, PGLog(..)
|
|
, mkInconsMetadataLog
|
|
, mkHttpAccessLogContext
|
|
, mkHttpErrorLogContext
|
|
, mkHttpLog
|
|
, HttpInfoLog(..)
|
|
, OperationLog(..)
|
|
, HttpLogContext(..)
|
|
, WebHookLog(..)
|
|
, HttpException
|
|
, getSourceFromFallback
|
|
, getSource
|
|
, HttpLog (..)
|
|
) where
|
|
|
|
import Data.Aeson
|
|
import Data.Aeson.Casing
|
|
import Data.Aeson.TH
|
|
import Data.Bits (shift, (.&.))
|
|
import Data.ByteString.Char8 (ByteString)
|
|
import Data.Int (Int64)
|
|
import Data.List (find)
|
|
import Data.Time.Clock
|
|
import Data.Word (Word32)
|
|
import Network.Socket (SockAddr (..))
|
|
import System.ByteOrder (ByteOrder (..), byteOrder)
|
|
import Text.Printf (printf)
|
|
|
|
import qualified Data.ByteString.Char8 as BS
|
|
import qualified Data.ByteString.Lazy as BL
|
|
import qualified Data.Text as T
|
|
import qualified Network.HTTP.Types as HTTP
|
|
import qualified Network.Wai as Wai
|
|
|
|
import Hasura.HTTP
|
|
import Hasura.Logging
|
|
import Hasura.Prelude
|
|
import Hasura.RQL.Types
|
|
import Hasura.Server.Compression
|
|
import Hasura.Server.Utils
|
|
|
|
data StartupLog
|
|
= StartupLog
|
|
{ slLogLevel :: !LogLevel
|
|
, slKind :: !T.Text
|
|
, slInfo :: !Value
|
|
} deriving (Show, Eq)
|
|
|
|
instance ToJSON StartupLog where
|
|
toJSON (StartupLog _ k info) =
|
|
object [ "kind" .= k
|
|
, "info" .= info
|
|
]
|
|
|
|
instance ToEngineLog StartupLog Hasura where
|
|
toEngineLog startupLog =
|
|
(slLogLevel startupLog, ELTStartup, toJSON startupLog)
|
|
|
|
data PGLog
|
|
= PGLog
|
|
{ plLogLevel :: !LogLevel
|
|
, plMessage :: !T.Text
|
|
} deriving (Show, Eq)
|
|
|
|
instance ToJSON PGLog where
|
|
toJSON (PGLog _ msg) =
|
|
object ["message" .= msg]
|
|
|
|
instance ToEngineLog PGLog Hasura where
|
|
toEngineLog pgLog =
|
|
(plLogLevel pgLog, ELTInternal ILTPgClient, toJSON pgLog)
|
|
|
|
data MetadataLog
|
|
= MetadataLog
|
|
{ mlLogLevel :: !LogLevel
|
|
, mlMessage :: !T.Text
|
|
, mlInfo :: !Value
|
|
} deriving (Show, Eq)
|
|
|
|
instance ToJSON MetadataLog where
|
|
toJSON (MetadataLog _ msg infoVal) =
|
|
object [ "message" .= msg
|
|
, "info" .= infoVal
|
|
]
|
|
|
|
instance ToEngineLog MetadataLog Hasura where
|
|
toEngineLog ml =
|
|
(mlLogLevel ml, ELTInternal ILTMetadata, toJSON ml)
|
|
|
|
mkInconsMetadataLog :: [InconsistentMetadataObj] -> MetadataLog
|
|
mkInconsMetadataLog objs =
|
|
MetadataLog LevelWarn "Inconsistent Metadata!" $
|
|
object [ "objects" .= objs]
|
|
|
|
data WebHookLog
|
|
= WebHookLog
|
|
{ whlLogLevel :: !LogLevel
|
|
, whlStatusCode :: !(Maybe HTTP.Status)
|
|
, whlUrl :: !T.Text
|
|
, whlMethod :: !HTTP.StdMethod
|
|
, whlError :: !(Maybe HttpException)
|
|
, whlResponse :: !(Maybe T.Text)
|
|
} deriving (Show)
|
|
|
|
instance ToEngineLog WebHookLog Hasura where
|
|
toEngineLog webHookLog =
|
|
(whlLogLevel webHookLog, ELTWebhookLog, toJSON webHookLog)
|
|
|
|
instance ToJSON WebHookLog where
|
|
toJSON whl =
|
|
object [ "status_code" .= (HTTP.statusCode <$> whlStatusCode whl)
|
|
, "url" .= whlUrl whl
|
|
, "method" .= show (whlMethod whl)
|
|
, "http_error" .= whlError whl
|
|
, "response" .= whlResponse whl
|
|
]
|
|
|
|
|
|
class (Monad m) => HttpLog m where
|
|
logHttpError
|
|
:: Logger Hasura
|
|
-- ^ the logger
|
|
-> Maybe UserInfo
|
|
-- ^ user info may or may not be present (error can happen during user resolution)
|
|
-> RequestId
|
|
-- ^ request id of the request
|
|
-> Wai.Request
|
|
-- ^ the Wai.Request object
|
|
-> Either BL.ByteString Value
|
|
-- ^ the actual request body (bytestring if unparsed, Aeson value if parsed)
|
|
-> QErr
|
|
-- ^ the error
|
|
-> [HTTP.Header]
|
|
-- ^ list of request headers
|
|
-> m ()
|
|
|
|
logHttpSuccess
|
|
:: Logger Hasura
|
|
-- ^ the logger
|
|
-> Maybe UserInfo
|
|
-- ^ user info may or may not be present (error can happen during user resolution)
|
|
-> RequestId
|
|
-- ^ request id of the request
|
|
-> Wai.Request
|
|
-- ^ the Wai.Request object
|
|
-> BL.ByteString
|
|
-- ^ the response bytes
|
|
-> BL.ByteString
|
|
-- ^ the compressed response bytes
|
|
-- ^ TODO: make the above two type represented
|
|
-> Maybe (UTCTime, UTCTime)
|
|
-- ^ possible execution time
|
|
-> Maybe CompressionType
|
|
-- ^ possible compression type
|
|
-> [HTTP.Header]
|
|
-- ^ list of request headers
|
|
-> m ()
|
|
|
|
|
|
-- | Log information about the HTTP request
|
|
data HttpInfoLog
|
|
= HttpInfoLog
|
|
{ hlStatus :: !HTTP.Status
|
|
, hlMethod :: !T.Text
|
|
, hlSource :: !T.Text
|
|
, hlPath :: !T.Text
|
|
, hlHttpVersion :: !HTTP.HttpVersion
|
|
, hlCompression :: !(Maybe CompressionType)
|
|
, hlHeaders :: ![HTTP.Header]
|
|
-- ^ all the request headers
|
|
} deriving (Show, Eq)
|
|
|
|
instance ToJSON HttpInfoLog where
|
|
toJSON (HttpInfoLog st met src path hv compressTypeM _) =
|
|
object [ "status" .= HTTP.statusCode st
|
|
, "method" .= met
|
|
, "ip" .= src
|
|
, "url" .= path
|
|
, "http_version" .= show hv
|
|
, "content_encoding" .= (compressionTypeToTxt <$> compressTypeM)
|
|
]
|
|
|
|
-- | Information about a GraphQL/Hasura metadata operation over HTTP
|
|
data OperationLog
|
|
= OperationLog
|
|
{ olRequestId :: !RequestId
|
|
, olUserVars :: !(Maybe UserVars)
|
|
, olResponseSize :: !(Maybe Int64)
|
|
, olQueryExecutionTime :: !(Maybe Double)
|
|
, olQuery :: !(Maybe Value)
|
|
, olRawQuery :: !(Maybe Text)
|
|
, olError :: !(Maybe QErr)
|
|
} deriving (Show, Eq)
|
|
|
|
$(deriveToJSON (aesonDrop 2 snakeCase)
|
|
{ omitNothingFields = True
|
|
} ''OperationLog)
|
|
|
|
data HttpLogContext
|
|
= HttpLogContext
|
|
{ hlcHttpInfo :: !HttpInfoLog
|
|
, hlcOperation :: !OperationLog
|
|
} deriving (Show, Eq)
|
|
$(deriveToJSON (aesonDrop 3 snakeCase) ''HttpLogContext)
|
|
|
|
mkHttpAccessLogContext
|
|
:: Maybe UserInfo
|
|
-- ^ Maybe because it may not have been resolved
|
|
-> RequestId
|
|
-> Wai.Request
|
|
-> BL.ByteString
|
|
-> Maybe (UTCTime, UTCTime)
|
|
-> Maybe CompressionType
|
|
-> [HTTP.Header]
|
|
-> HttpLogContext
|
|
mkHttpAccessLogContext userInfoM reqId req res mTimeT compressTypeM headers =
|
|
let http = HttpInfoLog
|
|
{ hlStatus = status
|
|
, hlMethod = bsToTxt $ Wai.requestMethod req
|
|
, hlSource = bsToTxt $ getSourceFromFallback req
|
|
, hlPath = bsToTxt $ Wai.rawPathInfo req
|
|
, hlHttpVersion = Wai.httpVersion req
|
|
, hlCompression = compressTypeM
|
|
, hlHeaders = headers
|
|
}
|
|
op = OperationLog
|
|
{ olRequestId = reqId
|
|
, olUserVars = userVars <$> userInfoM
|
|
, olResponseSize = respSize
|
|
, olQueryExecutionTime = respTime
|
|
, olQuery = Nothing
|
|
, olRawQuery = Nothing
|
|
, olError = Nothing
|
|
}
|
|
in HttpLogContext http op
|
|
where
|
|
status = HTTP.status200
|
|
respSize = Just $ BL.length res
|
|
respTime = computeTimeDiff mTimeT
|
|
|
|
mkHttpErrorLogContext
|
|
:: Maybe UserInfo
|
|
-- ^ Maybe because it may not have been resolved
|
|
-> RequestId
|
|
-> Wai.Request
|
|
-> QErr
|
|
-> Either BL.ByteString Value
|
|
-> Maybe (UTCTime, UTCTime)
|
|
-> Maybe CompressionType
|
|
-> [HTTP.Header]
|
|
-> HttpLogContext
|
|
mkHttpErrorLogContext userInfoM reqId req err query mTimeT compressTypeM headers =
|
|
let http = HttpInfoLog
|
|
{ hlStatus = qeStatus err
|
|
, hlMethod = bsToTxt $ Wai.requestMethod req
|
|
, hlSource = bsToTxt $ getSourceFromFallback req
|
|
, hlPath = bsToTxt $ Wai.rawPathInfo req
|
|
, hlHttpVersion = Wai.httpVersion req
|
|
, hlCompression = compressTypeM
|
|
, hlHeaders = headers
|
|
}
|
|
op = OperationLog
|
|
{ olRequestId = reqId
|
|
, olUserVars = userVars <$> userInfoM
|
|
, olResponseSize = Just $ BL.length $ encode err
|
|
, olQueryExecutionTime = computeTimeDiff mTimeT
|
|
, olQuery = either (const Nothing) Just query
|
|
, olRawQuery = either (Just . bsToTxt . BL.toStrict) (const Nothing) query
|
|
, olError = Just err
|
|
}
|
|
in HttpLogContext http op
|
|
|
|
data HttpLogLine
|
|
= HttpLogLine
|
|
{ _hlLogLevel :: !LogLevel
|
|
, _hlLogLine :: !HttpLogContext
|
|
}
|
|
|
|
instance ToEngineLog HttpLogLine Hasura where
|
|
toEngineLog (HttpLogLine logLevel logLine) =
|
|
(logLevel, ELTHttpLog, toJSON logLine)
|
|
|
|
mkHttpLog :: HttpLogContext -> HttpLogLine
|
|
mkHttpLog httpLogCtx =
|
|
let isError = isJust $ olError $ hlcOperation httpLogCtx
|
|
logLevel = bool LevelInfo LevelError isError
|
|
in HttpLogLine logLevel httpLogCtx
|
|
|
|
computeTimeDiff :: Maybe (UTCTime, UTCTime) -> Maybe Double
|
|
computeTimeDiff = fmap (realToFrac . uncurry (flip diffUTCTime))
|
|
|
|
getSourceFromSocket :: Wai.Request -> ByteString
|
|
getSourceFromSocket = BS.pack . showSockAddr . Wai.remoteHost
|
|
|
|
getSourceFromFallback :: Wai.Request -> ByteString
|
|
getSourceFromFallback req = fromMaybe (getSourceFromSocket req) $ getSource req
|
|
|
|
getSource :: Wai.Request -> Maybe ByteString
|
|
getSource req = addr
|
|
where
|
|
maddr = find (\x -> fst x `elem` ["x-real-ip", "x-forwarded-for"]) hdrs
|
|
addr = fmap snd maddr
|
|
hdrs = Wai.requestHeaders req
|
|
|
|
-- | A type for IP address in numeric string representation.
|
|
type NumericAddress = String
|
|
|
|
showIPv4 :: Word32 -> Bool -> NumericAddress
|
|
showIPv4 w32 little
|
|
| little = show b1 ++ "." ++ show b2 ++ "." ++ show b3 ++ "." ++ show b4
|
|
| otherwise = show b4 ++ "." ++ show b3 ++ "." ++ show b2 ++ "." ++ show b1
|
|
where
|
|
t1 = w32
|
|
t2 = shift t1 (-8)
|
|
t3 = shift t2 (-8)
|
|
t4 = shift t3 (-8)
|
|
b1 = t1 .&. 0x000000ff
|
|
b2 = t2 .&. 0x000000ff
|
|
b3 = t3 .&. 0x000000ff
|
|
b4 = t4 .&. 0x000000ff
|
|
|
|
showIPv6 :: (Word32,Word32,Word32,Word32) -> String
|
|
showIPv6 (w1,w2,w3,w4) =
|
|
printf "%x:%x:%x:%x:%x:%x:%x:%x" s1 s2 s3 s4 s5 s6 s7 s8
|
|
where
|
|
(s1,s2) = split16 w1
|
|
(s3,s4) = split16 w2
|
|
(s5,s6) = split16 w3
|
|
(s7,s8) = split16 w4
|
|
split16 w = (h1,h2)
|
|
where
|
|
h1 = shift w (-16) .&. 0x0000ffff
|
|
h2 = w .&. 0x0000ffff
|
|
|
|
-- | Convert 'SockAddr' to 'NumericAddress'. If the address is
|
|
-- IPv4-embedded IPv6 address, the IPv4 is extracted.
|
|
showSockAddr :: SockAddr -> NumericAddress
|
|
-- HostAddr is network byte order.
|
|
showSockAddr (SockAddrInet _ addr4) = showIPv4 addr4 (byteOrder == LittleEndian)
|
|
-- HostAddr6 is host byte order.
|
|
showSockAddr (SockAddrInet6 _ _ (0,0,0x0000ffff,addr4) _) = showIPv4 addr4 False
|
|
showSockAddr (SockAddrInet6 _ _ (0,0,0,1) _) = "::1"
|
|
showSockAddr (SockAddrInet6 _ _ addr6 _) = showIPv6 addr6
|
|
showSockAddr _ = "unknownSocket"
|