log-postgres (empty) → 0.7
raw patch · 4 files changed
+276/−0 lines, 4 filesdep +aesondep +aeson-prettydep +basesetup-changed
Dependencies added: aeson, aeson-pretty, base, base64-bytestring, bytestring, deepseq, hpqtypes, http-client, lifted-base, log-base, mtl, semigroups, split, text, text-show, time, unordered-containers, vector
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- log-postgres.cabal +63/−0
- src/Log/Backend/PostgreSQL.hs +181/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Scrive AB++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Andrzej Rybczak nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ log-postgres.cabal view
@@ -0,0 +1,63 @@+name: log-postgres+version: 0.7+synopsis: Structured logging solution (PostgreSQL back end)++description: PostgreSQL back end for the 'log' library.+ Depends on 'log-base'.++homepage: https://github.com/scrive/log+license: BSD3+license-file: LICENSE+author: Scrive AB+maintainer: Andrzej Rybczak <andrzej@rybczak.net>,+ Jonathan Jouty <jonathan@scrive.com>,+ Mikhail Glushenkov <mikhail@scrive.com>,+ Oleg Grenrus <oleg.grenrus@iki.fi>+copyright: Scrive AB+category: System+build-type: Simple+cabal-version: >=1.10+tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1++Source-repository head+ Type: git+ Location: https://github.com/scrive/log.git++library+ exposed-modules: Log.Backend.PostgreSQL+ build-depends: base <5,+ log-base >= 0.7,+ aeson >=0.11.0.0,+ aeson-pretty >=0.8.2,+ bytestring,+ base64-bytestring,+ deepseq,+ hpqtypes >=1.5,+ http-client,+ lifted-base,+ mtl,+ semigroups,+ split,+ text,+ text-show >= 2,+ time >= 1.5,+ unordered-containers,+ vector+ hs-source-dirs: src++ ghc-options: -O2 -Wall -funbox-strict-fields++ default-language: Haskell2010+ default-extensions: BangPatterns+ , FlexibleContexts+ , FlexibleInstances+ , GeneralizedNewtypeDeriving+ , LambdaCase+ , MultiParamTypeClasses+ , NoImplicitPrelude+ , OverloadedStrings+ , RankNTypes+ , RecordWildCards+ , ScopedTypeVariables+ , TypeFamilies+ , UndecidableInstances
+ src/Log/Backend/PostgreSQL.hs view
@@ -0,0 +1,181 @@+-- | PostgreSQL logging back-end.+module Log.Backend.PostgreSQL (pgLogger, withPgLogger) where++import Control.Applicative+import Control.Concurrent+import Control.Exception.Lifted+import Control.Monad.State.Lazy+import Data.Aeson+import Data.List.Split+import Data.Monoid.Utils+import Data.Semigroup+import Data.String+import Data.Typeable+import Database.PostgreSQL.PQTypes+import Prelude+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+import Log.Internal.Logger++newtype InvalidEncodingRecoveryAttempt = Attempt Int+ deriving Enum++-- | Create a 'pgLogger' for the duration of the given action, and+-- shut it down afterwards, making sure that all buffered messages are+-- actually written to the DB.+withPgLogger :: ConnectionSourceM IO -> (Logger -> IO r) -> IO r+withPgLogger cs act = do+ logger <- pgLogger cs+ withLogger logger act++{-# DEPRECATED pgLogger "Use 'withPgLogger' instead!" #-}++-- | Start an asynchronous logger thread that inserts log messages+-- into a PostgreSQL database.+--+-- Please use 'withPglogger' instead, which is more exception-safe+-- (see the note attached to 'mkBulkLogger').+pgLogger :: ConnectionSourceM IO -> IO Logger+pgLogger cs = mkBulkLogger loggerName+ (mapM_ (serialize $ Attempt 1) . chunksOf 1000)+ (return ())+ where+ 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) -> 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. (Applicative 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 [+ "("+ , "now()"+ , "," <?> n+ , "," <?> lmTime+ , "," <?> showLogLevel lmLevel+ , "," <?> lmComponent+ , "," <?> Array1 lmDomain+ , "," <?> lmMessage+ , "," <?> JSONB (encode lmData)+ , ")"+ ]++ ts :: TransactionSettings+ ts = def {+ tsAutoTransaction = False+ }