summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMikhailGlushenkov <>2016-11-25 09:08:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-11-25 09:08:00 (GMT)
commit698023f3b088024e82e91f31428f623bf57802fc (patch)
tree6bd6d7455a5a3c24fc8a3c1a4e321820d227932e
version 0.70.7
-rw-r--r--LICENSE30
-rw-r--r--Setup.hs2
-rw-r--r--log-postgres.cabal63
-rw-r--r--src/Log/Backend/PostgreSQL.hs181
4 files changed, 276 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..7e1c9db
--- /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
index 0000000..9a994af
--- /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
index 0000000..4332826
--- /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 <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
diff --git a/src/Log/Backend/PostgreSQL.hs b/src/Log/Backend/PostgreSQL.hs
new file mode 100644
index 0000000..3fb7c6b
--- /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
+ }