katip-rollbar (empty) → 0.1.0.0
raw patch · 6 files changed
+256/−0 lines, 6 filesdep +aesondep +asyncdep +basesetup-changed
Dependencies added: aeson, async, base, hostname, http-client, katip, rollbar-hs, stm-chans, text, time
Files
- LICENSE +30/−0
- README.md +1/−0
- Setup.hs +2/−0
- katip-rollbar.cabal +47/−0
- src/Katip/Scribes/Rollbar.hs +170/−0
- src/Lib.hs +6/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,1 @@+# katip-rollbar
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ katip-rollbar.cabal view
@@ -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
+ src/Katip/Scribes/Rollbar.hs view
@@ -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
+ src/Lib.hs view
@@ -0,0 +1,6 @@+module Lib+ ( someFunc+ ) where++someFunc :: IO ()+someFunc = putStrLn "someFunc"