diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for heavy-logger-instances + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2018 + +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 Author name here 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +# heavy-logger-instances + +This package contains some orphan instances for data types defined in heavy-logger package. + 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/heavy-logger-instances.cabal b/heavy-logger-instances.cabal new file mode 100644 --- /dev/null +++ b/heavy-logger-instances.cabal @@ -0,0 +1,65 @@ +-- This file has been generated from package.yaml by hpack version 0.20.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: b62e7d81b220f1d2169f712ba478c44f28f6adc244aec7872b75874f6a3a6a34 + +name: heavy-logger-instances +version: 0.1.0.0 +synopsis: Orphan instances for data types in heavy-logger package +description: Orphan instances for data types in heavy-logger package +category: System +homepage: https://github.com/portnov/heavy-logger#readme +bug-reports: https://github.com/portnov/heavy-logger/issues +author: Ilya Portnov +maintainer: portnov84@rambler.ru +copyright: 2018 Ilya Portnov +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + ChangeLog.md + README.md + +source-repository head + type: git + location: https://github.com/portnov/heavy-logger + +library + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , binary + , exceptions + , heavy-logger >=0.3.2.0 + , hsyslog >=5.0.1 + , template-haskell >=2.12 + , text >=1.2 + , text-format-heavy >=0.1.5.1 + exposed-modules: + System.Log.Heavy.Instances.Binary + other-modules: + Paths_heavy_logger_instances + default-language: Haskell2010 + +test-suite binary-test + type: exitcode-stdio-1.0 + main-is: Binary.hs + hs-source-dirs: + tests + build-depends: + base >=4.7 && <5 + , binary + , exceptions + , heavy-logger >=0.3.2.0 + , heavy-logger-instances + , hsyslog >=5.0.1 + , template-haskell >=2.12 + , text >=1.2 + , text-format-heavy >=0.1.5.1 + other-modules: + Paths_heavy_logger_instances + default-language: Haskell2010 diff --git a/src/System/Log/Heavy/Instances/Binary.hs b/src/System/Log/Heavy/Instances/Binary.hs new file mode 100644 --- /dev/null +++ b/src/System/Log/Heavy/Instances/Binary.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE RecordWildCards #-} +-- | This module contains instances of Binary type class for +-- data types defined in the heavy-logger package. +-- +module System.Log.Heavy.Instances.Binary where + +import Control.Applicative +import Control.Monad +import Data.Maybe +import Data.Binary +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as B +import Data.Text.Format.Heavy +import System.Log.Heavy +import System.Posix.Syslog +import Language.Haskell.TH.Syntax (Loc (..)) + +allVariables :: ClosedVarContainer c => c -> [(TL.Text, TL.Text)] +allVariables c = mapMaybe go (allVarNames c) + where + go name = + case lookupVar name c of + Nothing -> Nothing + Just var -> case formatAnyVar Nothing var of + Left _ -> Nothing + Right val -> Just (name, B.toLazyText val) + +getTextVariables :: Get [(TL.Text, TL.Text)] +getTextVariables = get + +instance Binary Priority where + put p = put (fromEnum p) + + get = toEnum <$> get + +instance Binary Level where + put l = do + put (levelName l) + put (levelInt l) + put (levelToPriority l) + + get = Level + <$> get + <*> get + <*> get + +instance Binary Loc where + put l = do + put (loc_filename l) + put (loc_package l) + put (loc_module l) + put (loc_start l) + put (loc_end l) + + get = Loc + <$> get + <*> get + <*> get + <*> get + <*> get + +instance Binary LogContextFilter where + put f = do + put (setInclude f) + put (setExclude f) + + get = LogContextFilter + <$> get + <*> get + +-- | Serialize Variable with default format +putVariableNoformat :: Variable -> Put +putVariableNoformat var = + case formatAnyVar Nothing var of + Left err -> fail err + Right val -> put (B.toLazyText val) + +-- | Deserialize Variable with default format +getVariableNoformat :: Get Variable +getVariableNoformat = do + text <- get + return $ Variable (text :: TL.Text) + +instance Binary LogContextFrame where + put f = do + put (length $ lcfVariables f) + forM_ (lcfVariables f) $ \(name, var) -> do + put name + putVariableNoformat var + put (lcfFilter f) + + get = do + n <- get :: Get Int + vars <- replicateM n $ do + name <- get + val <- getVariableNoformat + return (name, val) + fltr <- get + return (LogContextFrame vars fltr) + +-- | Please note: this implementation is limited: +-- +-- * It stores Variables as their Text representation +-- +-- * It does not take care of correct storing/restoring variable formats +-- +-- * When deserializing, it always uses @[(Text, Text)]@ as variables container. +-- +instance Binary LogMessage where + put (LogMessage {..}) = do + put lmLevel + put lmSource + put lmLocation + put lmFormatString + put (allVariables lmFormatVars) + put lmContext + + get = LogMessage + <$> get + <*> get + <*> get + <*> get + <*> getTextVariables + <*> get + diff --git a/tests/Binary.hs b/tests/Binary.hs new file mode 100644 --- /dev/null +++ b/tests/Binary.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +import Data.Binary +import qualified Data.Text.Lazy as TL +import Data.Text.Format.Heavy +import System.Log.Heavy +import System.Log.Heavy.Instances.Binary +import Language.Haskell.TH.Syntax (Loc (..)) + +testMessage :: LogMessage +testMessage = LogMessage { + lmLevel = debug_level, + lmSource = [], + lmLocation = Loc "" "" "" (0,0) (0,0), + lmFormatString = "hello, {}!", + lmFormatVars = Single ("world" :: TL.Text), + lmContext = [] +} + +printMessage :: LogMessage -> IO () +printMessage (LogMessage {..}) = do + print lmLevel + print lmSource + print lmLocation + print lmFormatString + -- print lmFormatVars + --print (lmFormatVars :: [(TL.Text, TL.Text)]) + print lmContext + +main = do + let str = encode testMessage + printMessage (decode str) +