diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/log-postgres.cabal b/log-postgres.cabal new file mode 100644 --- /dev/null +++ b/log-postgres.cabal @@ -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 , + Jonathan Jouty , + Mikhail Glushenkov , + Oleg Grenrus +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 diff --git a/src/Log/Backend/PostgreSQL.hs b/src/Log/Backend/PostgreSQL.hs new file mode 100644 --- /dev/null +++ b/src/Log/Backend/PostgreSQL.hs @@ -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 + }