diff --git a/log.cabal b/log.cabal --- a/log.cabal +++ b/log.cabal @@ -1,5 +1,5 @@ name: log -version: 0.2.2 +version: 0.2.3 synopsis: Structured logging solution with multiple backends description: A library that provides a way to record structured log messages with multiple backends. @@ -25,31 +25,34 @@ library exposed-modules: Log, - Log.Logger, + Log.Backend.PostgreSQL, + Log.Backend.StandardOutput, Log.Class, - Log.Data, - Log.Monad, Log.Class.Instances, - Log.Backend.PostgreSQL, - Log.Backend.StandardOutput + Log.Data, + Log.Logger, + Log.Monad build-depends: base <5, aeson >=0.6.2.0, + aeson-pretty >=0.7, + base64-bytestring, + bytestring, + deepseq, + exceptions >=0.6, + hpqtypes >=1.4, + lifted-base, + monad-control >=0.3, + monad-time, + mtl, + old-locale, + split, stm >=2.4, text, - monad-time, time, - deepseq, transformers-base, - exceptions >=0.6, - mtl, - monad-control >=0.3, unordered-containers, - bytestring, - split, - hpqtypes >=1.4, - aeson-pretty >=0.7, - old-locale + vector hs-source-dirs: src diff --git a/src/Log/Backend/PostgreSQL.hs b/src/Log/Backend/PostgreSQL.hs --- a/src/Log/Backend/PostgreSQL.hs +++ b/src/Log/Backend/PostgreSQL.hs @@ -1,30 +1,130 @@ -{-# LANGUAGE OverloadedStrings, RecordWildCards, ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, OverloadedStrings + , RecordWildCards, ScopedTypeVariables #-} module Log.Backend.PostgreSQL (pgLogger) where +import Control.Applicative import Control.Concurrent -import Control.Exception +import Control.Exception.Lifted +import Control.Monad.State.Lazy import Data.Aeson import Data.ByteString.Lazy (toStrict) +import Data.List.Split import Data.Monoid import Data.Monoid.Utils -import Data.List.Split -import Database.PostgreSQL.PQTypes +import Data.String +import Data.Typeable +import Database.PostgreSQL.PQTypes hiding (put) +import qualified Data.ByteString.Base64 as B64 +import qualified Data.Foldable as F +import qualified Data.HashMap.Strict as H +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Vector as V import Log.Data import Log.Logger +newtype InvalidEncodingRecoveryAttempt = Attempt Int + deriving Enum + -- | Create logger that inserts log messages into PostgreSQL database. pgLogger :: ConnectionSource -> IO Logger -pgLogger cs = mkBulkLogger "PostgreSQL" $ mapM_ serialize . chunksOf 1000 +pgLogger cs = mkBulkLogger loggerName + $ mapM_ (serialize $ Attempt 1) . chunksOf 1000 where - serialize :: [LogMessage] -> IO () - serialize msgs = runDBT cs ts (runSQL_ $ "INSERT INTO logs (insertion_time, insertion_order, time, level, component, domain, message, data) VALUES" <+> mintercalate ", " (map sqlifyMessage $ zip [1..] msgs)) `catches` [ + loggerName :: IsString s => s + loggerName = "PostgreSQL" + + sqlInsertLog :: SQL + sqlInsertLog = "INSERT INTO logs (insertion_time, insertion_order, time, level, component, domain, message, data) VALUES" + + serialize :: InvalidEncodingRecoveryAttempt -> [LogMessage] -> IO () + serialize !attempt msgs = runDBT cs ts (runSQL_ $ sqlInsertLog <+> mintercalate ", " (map sqlifyMessage $ zip [1..] msgs)) `catches` [ + -- Propagate base async exceptions thrown by the runtime system. Handler $ \(e::AsyncException) -> throwIO e - , Handler $ \(e::SomeException) -> do - putStrLn $ "PostgreSQL: couldn't serialize logs: " ++ show e ++ ", retrying in 10 seconds" - threadDelay $ 10 * 1000000 - serialize msgs + , Handler $ \(e::SomeException) -> case fromException e of + Just dbe@DBException{..} + | Just qe <- getEncodingQueryError dbe -> case attempt of + Attempt 1 -> do + -- If a client uses UTF-8 encoding (TODO: in fact it should + -- always be the case as Text is encoded as UTF-8 for sql + -- serialization), then this error occurs only when any of the + -- strings we want to serialize contains NULL bytes. In such + -- case we scan the logs and replace each NULL with "\0". + putStrLn $ loggerName ++ ": couldn't serialize logs due to character encoding error \"" ++ qeMessagePrimary qe ++ "\", removing NULL bytes and retrying" + serialize (succ attempt) $ map (\msg -> + -- If any text inside the message had NULL bytes, + -- add acknowledgment of that fact to its data. + case runState (mapTexts removeNULLs msg) False of + (newMsg, True) -> newMsg { + lmData = lmData newMsg `addPair` ("_log", "NULL bytes were escaped") + } + (_, False) -> msg) msgs + Attempt 2 -> do + -- This should never happen, but let us be paranoid for + -- a minute. If the error is still happening after removal + -- of NULL bytes, go through each message and encode all + -- texts as base64, effectively transforming them into ASCII. + putStrLn $ loggerName ++ ": couldn't serialize logs due to character encoding error \"" ++ qeMessagePrimary qe ++ "\" after NULL bytes were removed, encoding all texts in the problematic batch as base64 to make them ASCII" + serialize (succ attempt) $ map (\msg -> + let newMsg = runIdentity $ mapTexts convertBase64 msg + in newMsg { + lmData = lmData newMsg `addPair` ("_log", "Texts encoded as base64") + }) msgs + Attempt _ -> do + -- This can't happen, all texts are ASCII now. + putStrLn $ loggerName ++ ": impossible happened (>2 attempt failed because of character encoding error \"" ++ qeMessagePrimary qe ++ "\" even though all texts are ASCII), skipping the batch" + _ -> do + putStrLn $ loggerName ++ ": couldn't serialize logs:" <+> show e ++ ", retrying in 10 seconds" + threadDelay $ 10 * 1000000 + -- Do not increment the attempt here, it's used to + -- track invalid encoding recovery attempts only. + serialize attempt msgs ] + + addPair :: Value -> (T.Text, Value) -> Value + addPair data_ (name, value) = case data_ of + Object obj -> Object $ H.insert name value obj + _ -> object [ + "_data" .= data_ + , "_log" .= value + ] + + getEncodingQueryError :: DBException -> Maybe DetailedQueryError + getEncodingQueryError DBException{..} + | Just (qe::DetailedQueryError) <- cast dbeError + , qeErrorCode qe == CharacterNotInRepertoire + || qeErrorCode qe == UntranslatableCharacter = Just qe + | otherwise = Nothing + + convertBase64 :: T.Text -> Identity T.Text + convertBase64 = return . T.decodeLatin1 . B64.encode . T.encodeUtf8 + + removeNULLs :: T.Text -> State Bool T.Text + removeNULLs s = do + let newS = T.replace "\0" "\\0" s + when (T.length newS /= T.length s) $ put True + return newS + + mapTexts :: forall m. Monad m => (T.Text -> m T.Text) -> LogMessage -> m LogMessage + mapTexts doText lm = do + component <- doText $ lmComponent lm + domain <- mapM doText $ lmDomain lm + message <- doText $ lmMessage lm + data_ <- doValue $ lmData lm + return lm { + lmComponent = component + , lmDomain = domain + , lmMessage = message + , lmData = data_ + } + where + doValue :: Value -> m Value + doValue (Object obj) = Object <$> F.foldrM (\(name, value) acc -> H.insert + <$> doText name <*> doValue value <*> pure acc) H.empty (H.toList obj) + doValue (Array arr) = Array <$> V.mapM doValue arr + doValue (String s) = String <$> doText s + doValue v = return v sqlifyMessage :: (Int, LogMessage) -> SQL sqlifyMessage (n, LogMessage{..}) = mconcat [