-- This Source Code Form is subject to the terms of the Mozilla Public
-- License, v. 2.0. If a copy of the MPL was not distributed with this
-- file, You can obtain one at http://mozilla.org/MPL/2.0/.

{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}

-- | 'Msg' and 'ToBytes' assist in constructing log messages.
-- For example:
--
-- @
-- > g <- new (setBufSize 1 . setOutput StdOut $ defSettings)
-- > info g $ msg "some text" ~~ "key" .= "value" ~~ "okay" .= True
-- 2014-04-28T21:18:20Z, I, some text, key=value, okay=True
-- >
-- @
module System.Logger.Message
    ( ToBytes (..)
    , Msg
    , Builder
    , Element (..)
    , msg
    , field
    , (.=)
    , (+++)
    , (~~)
    , val
    , eval
    , builderSize
    , builderBytes
    , render
    , renderDefault
    , renderNetstr
    ) where

#if MIN_VERSION_base(4,9,0)
import Data.Semigroup as Sem
#endif

#if !(MIN_VERSION_base(4,8,0))
import Data.Monoid
#endif

import Data.ByteString (ByteString)
import Data.Double.Conversion.Text
import Data.Int
import Data.String
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Word
import GHC.Float

import qualified Data.ByteString                     as S
import qualified Data.ByteString.Lazy                as L
import qualified Data.ByteString.Builder             as B
import qualified Data.ByteString.Builder.Extra       as B
import qualified Data.Text                           as T
import qualified Data.Text.Lazy                      as TL
import qualified Data.Text.Lazy.Encoding             as TL

data Builder = Builder !Int B.Builder

instance IsString Builder where
    fromString :: String -> Builder
fromString = String -> Builder
forall a. ToBytes a => a -> Builder
bytes

appendBuilder:: Builder -> Builder -> Builder
appendBuilder :: Builder -> Builder -> Builder
appendBuilder (Builder Int
x Builder
a) (Builder Int
y Builder
b) = Int -> Builder -> Builder
Builder (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y) (Builder
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b)

#if MIN_VERSION_base(4,9,0)
instance Sem.Semigroup Builder where
    <> :: Builder -> Builder -> Builder
(<>) = Builder -> Builder -> Builder
appendBuilder
#endif

instance Monoid Builder where
    mempty :: Builder
mempty = Int -> Builder -> Builder
Builder Int
0 Builder
forall a. Monoid a => a
mempty
#if MIN_VERSION_base(4,11,0)
    -- mappend definitions are redundant now
#elif MIN_VERSION_base(4,9,0)
    mappend = (Sem.<>)
#else
    mappend = appendBuilder
#endif

eval :: Builder -> L.ByteString
eval :: Builder -> ByteString
eval (Builder Int
n Builder
b) = AllocationStrategy -> ByteString -> Builder -> ByteString
B.toLazyByteStringWith (Int -> Int -> AllocationStrategy
B.safeStrategy Int
n Int
256) ByteString
L.empty Builder
b

builderSize :: Builder -> Int
builderSize :: Builder -> Int
builderSize (Builder Int
n Builder
_) = Int
n

builderBytes :: Builder -> B.Builder
builderBytes :: Builder -> Builder
builderBytes (Builder Int
_ Builder
b) = Builder
b

-- | Convert some value to a 'Builder'.
class ToBytes a where
    bytes :: a -> Builder

instance ToBytes Builder      where bytes :: Builder -> Builder
bytes Builder
x = Builder
x
instance ToBytes L.ByteString where bytes :: ByteString -> Builder
bytes ByteString
x = Int -> Builder -> Builder
Builder (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> Int64 -> Int
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
L.length ByteString
x) (ByteString -> Builder
B.lazyByteString ByteString
x)
instance ToBytes ByteString   where bytes :: ByteString -> Builder
bytes ByteString
x = Int -> Builder -> Builder
Builder (ByteString -> Int
S.length ByteString
x) (ByteString -> Builder
B.byteString ByteString
x)
instance ToBytes Int          where bytes :: Int -> Builder
bytes Int
x = Int -> Builder -> Builder
Builder (Int -> Int
forall a. Integral a => a -> Int
len10 Int
x) (Int -> Builder
B.intDec Int
x)
instance ToBytes Int8         where bytes :: Int8 -> Builder
bytes Int8
x = Int -> Builder -> Builder
Builder (Int8 -> Int
forall a. Integral a => a -> Int
len10 Int8
x) (Int8 -> Builder
B.int8Dec Int8
x)
instance ToBytes Int16        where bytes :: Int16 -> Builder
bytes Int16
x = Int -> Builder -> Builder
Builder (Int16 -> Int
forall a. Integral a => a -> Int
len10 Int16
x) (Int16 -> Builder
B.int16Dec Int16
x)
instance ToBytes Int32        where bytes :: Int32 -> Builder
bytes Int32
x = Int -> Builder -> Builder
Builder (Int32 -> Int
forall a. Integral a => a -> Int
len10 Int32
x) (Int32 -> Builder
B.int32Dec Int32
x)
instance ToBytes Int64        where bytes :: Int64 -> Builder
bytes Int64
x = Int -> Builder -> Builder
Builder (Int64 -> Int
forall a. Integral a => a -> Int
len10 Int64
x) (Int64 -> Builder
B.int64Dec Int64
x)
instance ToBytes Integer      where bytes :: Integer -> Builder
bytes Integer
x = Int -> Builder -> Builder
Builder (Integer -> Int
forall a. Integral a => a -> Int
len10 Integer
x) (Integer -> Builder
B.integerDec Integer
x)
instance ToBytes Word         where bytes :: Word -> Builder
bytes Word
x = Int -> Builder -> Builder
Builder (Word -> Int
forall a. Integral a => a -> Int
len10 Word
x) (Word -> Builder
B.wordDec Word
x)
instance ToBytes Word8        where bytes :: Word8 -> Builder
bytes Word8
x = Int -> Builder -> Builder
Builder (Word8 -> Int
forall a. Integral a => a -> Int
len10 Word8
x) (Word8 -> Builder
B.word8Dec Word8
x)
instance ToBytes Word16       where bytes :: Word16 -> Builder
bytes Word16
x = Int -> Builder -> Builder
Builder (Word16 -> Int
forall a. Integral a => a -> Int
len10 Word16
x) (Word16 -> Builder
B.word16Dec Word16
x)
instance ToBytes Word32       where bytes :: Word32 -> Builder
bytes Word32
x = Int -> Builder -> Builder
Builder (Word32 -> Int
forall a. Integral a => a -> Int
len10 Word32
x) (Word32 -> Builder
B.word32Dec Word32
x)
instance ToBytes Word64       where bytes :: Word64 -> Builder
bytes Word64
x = Int -> Builder -> Builder
Builder (Word64 -> Int
forall a. Integral a => a -> Int
len10 Word64
x) (Word64 -> Builder
B.word64Dec Word64
x)
instance ToBytes Float        where bytes :: Float -> Builder
bytes Float
x = Text -> Builder
forall a. ToBytes a => a -> Builder
bytes (Double -> Text
toShortest (Double -> Text) -> Double -> Text
forall a b. (a -> b) -> a -> b
$ Float -> Double
float2Double Float
x)
instance ToBytes Double       where bytes :: Double -> Builder
bytes Double
x = Text -> Builder
forall a. ToBytes a => a -> Builder
bytes (Double -> Text
toShortest Double
x)
instance ToBytes Text         where bytes :: Text -> Builder
bytes Text
x = ByteString -> Builder
forall a. ToBytes a => a -> Builder
bytes (Text -> ByteString
encodeUtf8 Text
x)
instance ToBytes TL.Text      where bytes :: Text -> Builder
bytes Text
x = ByteString -> Builder
forall a. ToBytes a => a -> Builder
bytes (Text -> ByteString
TL.encodeUtf8 Text
x)
instance ToBytes Char         where bytes :: Char -> Builder
bytes Char
x = Text -> Builder
forall a. ToBytes a => a -> Builder
bytes (Char -> Text
T.singleton Char
x)
instance ToBytes [Char]       where bytes :: String -> Builder
bytes String
x = Text -> Builder
forall a. ToBytes a => a -> Builder
bytes (String -> Text
TL.pack String
x)

instance ToBytes Bool where
    bytes :: Bool -> Builder
bytes Bool
True  = Int -> Builder -> Builder
Builder Int
4 (ByteString -> Builder
B.byteString ByteString
"True")
    bytes Bool
False = Int -> Builder -> Builder
Builder Int
5 (ByteString -> Builder
B.byteString ByteString
"False")

{-# INLINE len10 #-}
len10 :: Integral a => a -> Int
len10 :: forall a. Integral a => a -> Int
len10 !a
n = if a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0 then a -> Int -> Int
forall {t} {t}. (Integral t, Num t) => t -> t -> t
go a
n Int
0 else Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ a -> Int -> Int
forall {t} {t}. (Integral t, Num t) => t -> t -> t
go (-a
n) Int
0
  where
    go :: t -> t -> t
go  t
0 !t
a = t
a
    go !t
x !t
a = t -> t -> t
go (t
x t -> t -> t
forall a. Integral a => a -> a -> a
`div` t
10) (t
a t -> t -> t
forall a. Num a => a -> a -> a
+ t
1)

-- | Type representing log messages.
newtype Msg = Msg { Msg -> [Element]
elements :: [Element] }

data Element
    = Bytes Builder
    | Field Builder Builder

-- | Turn some value into a 'Msg'.
msg :: ToBytes a => a -> Msg -> Msg
msg :: forall a. ToBytes a => a -> Msg -> Msg
msg a
p (Msg [Element]
m) = [Element] -> Msg
Msg ([Element] -> Msg) -> [Element] -> Msg
forall a b. (a -> b) -> a -> b
$ Builder -> Element
Bytes (a -> Builder
forall a. ToBytes a => a -> Builder
bytes a
p) Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Element]
m

-- | Render some field, i.e. a key-value pair delimited by \"=\".
field :: ToBytes a => ByteString -> a -> Msg -> Msg
field :: forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
k a
v (Msg [Element]
m) = [Element] -> Msg
Msg ([Element] -> Msg) -> [Element] -> Msg
forall a b. (a -> b) -> a -> b
$ Builder -> Builder -> Element
Field (ByteString -> Builder
forall a. ToBytes a => a -> Builder
bytes ByteString
k) (a -> Builder
forall a. ToBytes a => a -> Builder
bytes a
v) Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Element]
m

-- | Alias of 'field'.
(.=) :: ToBytes a => ByteString -> a -> Msg -> Msg
.= :: forall a. ToBytes a => ByteString -> a -> Msg -> Msg
(.=) = ByteString -> a -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field
infixr 5 .=

-- | Alias of '.' with lowered precedence to allow combination with '.='
-- without requiring parentheses.
(~~) :: (b -> c) -> (a -> b) -> a -> c
~~ :: forall b c a. (b -> c) -> (a -> b) -> a -> c
(~~) = (b -> c) -> (a -> b) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)
infixr 4 ~~

-- | Concatenate two 'ToBytes' values.
(+++) :: (ToBytes a, ToBytes b) => a -> b -> Builder
a
a +++ :: forall a b. (ToBytes a, ToBytes b) => a -> b -> Builder
+++ b
b = a -> Builder
forall a. ToBytes a => a -> Builder
bytes a
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> b -> Builder
forall a. ToBytes a => a -> Builder
bytes b
b
infixr 6 +++

-- | Type restriction. Useful to disambiguate string literals when
-- using @OverloadedStrings@ pragma.
val :: ByteString -> Builder
val :: ByteString -> Builder
val = ByteString -> Builder
forall a. ToBytes a => a -> Builder
bytes

-- | Construct elements, call a renderer, and run the whole builder
-- into a 'L.ByteString'.
render :: ([Element] -> B.Builder) -> (Msg -> Msg) -> L.ByteString
render :: ([Element] -> Builder) -> (Msg -> Msg) -> ByteString
render [Element] -> Builder
f Msg -> Msg
m = Builder -> ByteString
finish (Builder -> ByteString) -> (Msg -> Builder) -> Msg -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Element] -> Builder
f ([Element] -> Builder) -> (Msg -> [Element]) -> Msg -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> [Element]
elements (Msg -> [Element]) -> (Msg -> Msg) -> Msg -> [Element]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> Msg
m (Msg -> ByteString) -> Msg -> ByteString
forall a b. (a -> b) -> a -> b
$ Msg
empty

-- | Simple 'Renderer' with '=' between field names and values and a custom
-- separator.
renderDefault :: ByteString -> [Element] -> B.Builder
renderDefault :: ByteString -> [Element] -> Builder
renderDefault ByteString
s = Builder -> [Element] -> Builder
encAll Builder
forall a. Monoid a => a
mempty
  where
    encAll :: Builder -> [Element] -> Builder
encAll !Builder
acc    []  = Builder
acc
    encAll !Builder
acc (Element
b:[]) = Builder
acc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Element -> Builder
encOne Element
b
    encAll !Builder
acc (Element
b:[Element]
bb) = Builder -> [Element] -> Builder
encAll (Builder
acc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Element -> Builder
encOne Element
b Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
sep) [Element]
bb

    encOne :: Element -> Builder
encOne (Bytes (Builder Int
_ Builder
b))               = Builder
b
    encOne (Field (Builder Int
_ Builder
k) (Builder Int
_ Builder
v)) = Builder
k Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
eq Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
v

    eq :: Builder
eq  = Char -> Builder
B.char8 Char
'='
    sep :: Builder
sep = ByteString -> Builder
B.byteString ByteString
s

-- | 'Renderer' that uses <http://cr.yp.to/proto/netstrings.txt netstring>
-- encoding for log lines.
renderNetstr :: [Element] -> B.Builder
renderNetstr :: [Element] -> Builder
renderNetstr = Builder -> [Element] -> Builder
encAll Builder
forall a. Monoid a => a
mempty
  where
    encAll :: Builder -> [Element] -> Builder
encAll !Builder
acc []     = Builder
acc
    encAll !Builder
acc (Element
b:[Element]
bb) = Builder -> [Element] -> Builder
encAll (Builder
acc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Element -> Builder
encOne Element
b) [Element]
bb

    encOne :: Element -> Builder
encOne (Bytes   Builder
e) = Builder -> Builder
netstr Builder
e
    encOne (Field Builder
k Builder
v) = Builder -> Builder
netstr Builder
k Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
eq Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
netstr Builder
v

    eq :: Builder
eq = ByteString -> Builder
B.byteString ByteString
"1:=,"

finish :: B.Builder -> L.ByteString
finish :: Builder -> ByteString
finish = AllocationStrategy -> ByteString -> Builder -> ByteString
B.toLazyByteStringWith (Int -> Int -> AllocationStrategy
B.untrimmedStrategy Int
256 Int
256) ByteString
"\n"

empty :: Msg
empty :: Msg
empty = [Element] -> Msg
Msg []

netstr :: Builder -> B.Builder
netstr :: Builder -> Builder
netstr (Builder !Int
n Builder
b) = Int -> Builder
B.intDec Int
n Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
colon Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
comma

colon, comma :: B.Builder
colon :: Builder
colon = Char -> Builder
B.char8 Char
':'
comma :: Builder
comma = Char -> Builder
B.char8 Char
','