diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Hardy Jones (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 Hardy Jones 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,1 @@ +# katip-rollbar 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/katip-rollbar.cabal b/katip-rollbar.cabal new file mode 100644 --- /dev/null +++ b/katip-rollbar.cabal @@ -0,0 +1,47 @@ +-- This file has been generated from package.yaml by hpack version 0.20.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 5e49ac727bac12f49749f6c15a24932d8a6f1004c5195935c7b28cd1f5234089 + +name: katip-rollbar +version: 0.1.0.0 +synopsis: Katip scribe that logs to Rollbar +category: Logging +homepage: https://github.com/joneshf/katip-rollbar#readme +bug-reports: https://github.com/joneshf/katip-rollbar/issues +author: Hardy Jones +maintainer: jones3.hardy@gmail.com +copyright: 2018 Hardy Jones +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/joneshf/katip-rollbar + +library + hs-source-dirs: + src + build-depends: + aeson >=1.2 && <1.3 + , async >=2.1 && <2.2 + , base >=4.7 && <5 + , hostname >=1.0 && <1.1 + , http-client >=0.5.10 + , katip >=0.5 && <0.6 + , rollbar-hs >=0.2 && <0.3 + , stm-chans >=3.0 && <3.1 + , text >=1.2 && <1.3 + , time >=1.8 && <1.9 + exposed-modules: + Katip.Scribes.Rollbar + Lib + other-modules: + Paths_katip_rollbar + default-language: Haskell2010 diff --git a/src/Katip/Scribes/Rollbar.hs b/src/Katip/Scribes/Rollbar.hs new file mode 100644 --- /dev/null +++ b/src/Katip/Scribes/Rollbar.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Katip.Scribes.Rollbar where + +import Prelude hiding (error) + +import "base" Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) +import "base" Control.Monad (replicateM, when) +import "base" Data.Foldable (for_) +import "base" Data.Functor (void) +import "base" GHC.Conc (atomically) + +import "async" Control.Concurrent.Async (async, waitCatch) +import "stm-chans" Control.Concurrent.STM.TBMQueue + ( TBMQueue + , closeTBMQueue + , newTBMQueueIO + , readTBMQueue + , writeTBMQueue + ) +import "aeson" Data.Aeson (Value) +import "text" Data.Text.Lazy (toStrict) +import "text" Data.Text.Lazy.Builder (toLazyText) +import "time" Data.Time.Clock (UTCTime) +import "katip" Katip + ( LogItem + , Scribe(Scribe, liPush, scribeFinalizer) + , Severity(DebugS, ErrorS, InfoS, NoticeS, WarningS) + , Verbosity + , getEnvironment + , itemJson + , permitItem + , unLogStr + , _itemEnv + , _itemHost + , _itemMessage + , _itemSeverity + , _itemTime + ) +import "hostname" Network.HostName (HostName) +import "http-client" Network.HTTP.Client (Manager) +import "rollbar-hs" Rollbar.AccessToken (AccessToken) +import "rollbar-hs" Rollbar.API (itemsPOST') +import "rollbar-hs" Rollbar.Item + ( Item(Item, accessToken, itemData) + , critical + , debug + , error + , info + , warning + ) +import "rollbar-hs" Rollbar.Item.Body (MessageBody(MessageBody)) +import "rollbar-hs" Rollbar.Item.CodeVersion (CodeVersion) +import "rollbar-hs" Rollbar.Item.Data + ( Data(framework, server, timestamp) + ) +import "rollbar-hs" Rollbar.Item.Environment (Environment(Environment)) +import "rollbar-hs" Rollbar.Item.MissingHeaders (RemoveHeaders) +import "rollbar-hs" Rollbar.Item.Server + ( Branch + , Server(Server, branch, host, root, serverCodeVersion) + ) + +import qualified "katip" Katip + +queueSize :: Int +queueSize = 10 + +workerSize :: Int +workerSize = 3 + +mkRollbarScribe :: + RemoveHeaders headers => + proxy headers -> + AccessToken -> + Maybe Branch -> + Maybe CodeVersion -> + Manager -> + Severity -> + Verbosity -> + IO Scribe +mkRollbarScribe proxy accessToken branch codeVersion manager severity verbosity = do + queue <- newTBMQueueIO queueSize + finalize <- newEmptyMVar + setupWorkers proxy queue finalize manager + let liPush item = when (permitItem severity item) $ + atomically (writeTBMQueue queue $ rollbarItem' item) + rollbarItem' item = rollbarItem proxy accessToken branch codeVersion verbosity item + scribeFinalizer = do + putMVar finalize () + takeMVar finalize + pure Scribe { liPush, scribeFinalizer } + +rollbarItem :: + (LogItem a, RemoveHeaders headers) => + proxy headers -> + AccessToken -> + Maybe Branch -> + Maybe CodeVersion -> + Verbosity -> + Katip.Item a -> + Item Value ("Authorization" ': headers) +rollbarItem _ accessToken branch serverCodeVersion verbosity item = + Item { accessToken, itemData } + where + environment :: Environment + environment = Environment (getEnvironment $ _itemEnv item) + hostName :: HostName + hostName = _itemHost item + itemData :: Data Value ("Authorization" ': headers) + itemData = itemData' + { framework = Just "katip" + , server = Just server + , timestamp = Just timestamp + } + itemData' :: Data Value ("Authorization" ': headers) + itemData' = case severity of + DebugS -> debug environment (Just messageBody) value + InfoS -> info environment (Just messageBody) value + NoticeS -> info environment (Just messageBody) value + WarningS -> warning environment (Just messageBody) value + ErrorS -> error environment (Just messageBody) value + _ -> critical environment (Just messageBody) value + messageBody :: MessageBody + messageBody = + MessageBody (toStrict $ toLazyText $ unLogStr $ _itemMessage item) + server :: Server + server = Server { branch, host = Just hostName, root = Nothing, serverCodeVersion } + severity :: Severity + severity = _itemSeverity item + timestamp :: UTCTime + timestamp = _itemTime item + value :: Value + value = itemJson verbosity item + +-- | Setup the workers and wait until the finalizer is evaluated. +-- Then, close the queueu, wait for the workers and continue finalization. +setupWorkers :: + RemoveHeaders headers => + proxy headers -> + TBMQueue (Item Value ("Authorization" ': headers)) -> + MVar () -> + Manager -> + IO () +setupWorkers proxy queue finalize manager = void $ async $ do + workers <- replicateM workerSize (async $ mkWorker proxy manager queue) + takeMVar finalize + atomically (closeTBMQueue queue) + for_ workers waitCatch + putMVar finalize () + +mkWorker :: + (RemoveHeaders headers) => + proxy headers -> + Manager -> + TBMQueue (Item Value ("Authorization" ': headers)) -> + IO () +mkWorker _ manager queue = go + where + go = do + item' <- atomically (readTBMQueue queue) + for_ item' $ \item -> do + void (itemsPOST' manager item) + go diff --git a/src/Lib.hs b/src/Lib.hs new file mode 100644 --- /dev/null +++ b/src/Lib.hs @@ -0,0 +1,6 @@ +module Lib + ( someFunc + ) where + +someFunc :: IO () +someFunc = putStrLn "someFunc"