diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2016 + +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/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/simple-logging.cabal b/simple-logging.cabal new file mode 100644 --- /dev/null +++ b/simple-logging.cabal @@ -0,0 +1,59 @@ +name: simple-logging +version: 0.1.0.0 +cabal-version: >=1.10 +build-type: Simple +license: MIT +license-file: LICENSE +copyright: 2017 Luka Horvat +maintainer: luka.horvat9@gmail.com +homepage: https://gitlab.com/haskell-hr/logging +synopsis: Logging effect to plug into the simple-effects framework +category: Logging +author: Luka Horvat + +source-repository head + type: git + location: https://gitlab.com/haskell-hr/logging.git + +library + exposed-modules: + Control.Effects.Logging + Control.Effects.Logging.Sentry + build-depends: + base >=4.7 && <5, + aeson >=1.0.2.1, + unordered-containers >=0.2.8.0, + vector >=0.11.0.0, + wreq >=0.5.0.1, + time >=1.6.0.1, + uuid >=1.3.13, + bytestring >=0.10.8.1, + iso8601-time >=0.1.4, + text >=1.2.2.1, + simple-effects >=0.9.0.0, + exceptions >=0.8.3, + mtl >=2.2.1, + string-conv >=0.1.2, + MonadRandom >=0.5.1, + lens >=4.15.1 + default-language: Haskell2010 + default-extensions: NoImplicitPrelude OverloadedStrings + hs-source-dirs: src + other-modules: + Interlude + ghc-options: -Wall + +test-suite logging-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-depends: + base >=4.9.1.0, + logging -any, + simple-effects >=0.9.0.0 + default-language: Haskell2010 + default-extensions: MultiParamTypeClasses TypeFamilies + NoMonomorphismRestriction FlexibleContexts NoImplicitPrelude + hs-source-dirs: test + other-modules: + Module1 + ghc-options: -threaded -rtsopts -with-rtsopts=-N diff --git a/src/Control/Effects/Logging.hs b/src/Control/Effects/Logging.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effects/Logging.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE TypeFamilies, FlexibleContexts, MultiParamTypeClasses, RankNTypes, ConstraintKinds + , RecordWildCards #-} +{-# LANGUAGE GADTs, DataKinds #-} +-- | Use this module to add logging to your monad. +-- A log is a structured value that can hold information like severity, log message, timestamp, +-- callstack, etc. +-- +-- Logging is treated like a stream of logs comming from your application and functions that +-- transform the logs take a stream and output a stream. Functions like 'logInfo' push a new log +-- into the stream and functions like 'setTimestampToNow' take a stream of logs and attach extra +-- info onto each log (current time in this case). +-- +-- Read the documentation of individual functions to get a feel for what you can do. +module Control.Effects.Logging (module Control.Effects.Logging) where + +import Interlude +import Control.Effects as Control.Effects.Logging +import Control.Effects.Signal + +import Data.Text hiding (length) +import Data.Time.ISO8601 +import qualified Data.ByteString as BS + +import GHC.Stack +import Data.Time (UTCTime, getCurrentTime) + +-- | The logging effect. +data Logging = Logging +data instance Effect Logging method mr where + LoggingMsg :: Log -> Effect Logging 'Logging 'Msg + LoggingRes :: Effect Logging 'Logging 'Res + +-- | Arbitrary piece of text. Logs contain a list of these. +newtype Tag = Tag Text deriving (Eq, Ord, Read, Show) + +-- | A name for a "layer" of your application. Typically, a log will contain a stack of contexts. +-- Think of it as a call stack specific for your application. +newtype Context = Context { getContext :: Text } deriving (Eq, Ord, Read, Show) + +-- | The severity of the log. +data Level = Fatal | Error | Warning | Info | Debug deriving (Eq, Ord, Read, Show) + +-- | If a notion of a user exists for your application, you can add this information to your logs. +data LogUser = LogUser { logUserId :: Text + , logUserEmail :: Maybe Text + , logUserUsername :: Maybe Text } + deriving (Eq, Ord, Read, Show) + +addIfExists :: Text -> Maybe Value -> [(Text, Value)] -> [(Text, Value)] +addIfExists _ Nothing ps = ps +addIfExists n (Just v) ps = (n, v) : ps + +instance ToJSON LogUser where + toJSON LogUser{..} = + object $ ["id" .= logUserId] + & addIfExists "username" (String <$> logUserUsername) + & addIfExists "email" (String <$> logUserEmail) + +-- | Breadcrumbs are the steps that happened before a log. +data Crumb = Crumb { crumbTimestamp :: UTCTime + , crumbMessage :: Maybe Text + , crumbCategory :: Text + , crumbData :: CrumbData } + deriving (Eq, Read, Show) + +-- | Crumbs come in two varieties. A normal crumb is a list of key-value pairs. There's also a +-- 'HttpCrumb' where you can put more specific information about the processed HTTP request (if +-- your application is a web server). +data CrumbData = DefaultCrumb [(Text, Value)] + | HttpCrumb { crumbUrl :: Text + , crumbMethod :: Text + , crumbStatusCode :: Int + , crumbReason :: Text } + deriving (Eq, Read, Show) + +instance ToJSON CrumbData where + toJSON (DefaultCrumb d) = object d + toJSON HttpCrumb{..} = + object [ "url" .= crumbUrl + , "method" .= crumbMethod + , "status_code" .= crumbStatusCode + , "reason" .= crumbReason ] + +instance ToJSON Crumb where + toJSON Crumb{..} = + object $ [ "timestamp" .= formatISO8601 crumbTimestamp + , "category" .= crumbCategory + , "type" .= case crumbData of + DefaultCrumb _ -> "default" :: Text + HttpCrumb{} -> "http" + , "data" .= crumbData ] + & addIfExists "message" (String <$> crumbMessage) + +data Log = Log { logMessage :: Text + , logLevel :: Level + , logTags :: [Tag] + , logContext :: [Context] + , logUser :: Maybe LogUser + , logCrumbs :: [Crumb] + , logData :: ByteString + , logTimestamp :: Maybe UTCTime + , logCallStack :: CallStack } + deriving (Show) + +-- | A generic exception holding only a piece of text. +newtype GenericException = GenericException Text deriving (Eq, Ord, Read, Show) +instance Exception GenericException + +-- | Send a single log into the stream. +logEffect :: MonadEffect Logging m => Log -> m () +logEffect = void . effect . LoggingMsg + +-- | A generic handler for logs. Since it's polymorphic in 'm' you can choose to emit more logs +-- and make it a log transformer instead. +handleLogging :: Functor m => (Log -> m ()) -> EffectHandler Logging m a -> m a +handleLogging f = handleEffect (\(LoggingMsg l) -> LoggingRes <$ f l) + +-- | Add a new context on top of every log that comes from the given computation. +layerLogs :: MonadEffect Logging m => Context -> EffectHandler Logging m a -> m a +layerLogs ctx = handleLogging (\log' -> logEffect (log' { logContext = ctx : logContext log' })) + +-- | Get the bottom-most context if it exists. +originContext :: Log -> Maybe Context +originContext Log{..} = listToMaybe (Interlude.reverse logContext) + +logInfo, logWarning, logError :: (HasCallStack, MonadEffect Logging m) => Text -> m () +logInfo msg = logEffect $ Log msg Info [] [] Nothing [] "" Nothing callStack +logWarning msg = logEffect $ Log msg Warning [] [] Nothing [] "" Nothing callStack +logError msg = logEffect $ Log msg Error [] [] Nothing [] "" Nothing callStack + +-- | Log an error and then throw the given exception. +logAndError :: (Exception e, MonadEffect Logging m, MonadThrow m, HasCallStack) => Text -> e -> m a +logAndError msg err = logError msg >> throwM err + +-- | Log an error and then throw a checked exception. +-- Read about checked exceptions in 'Control.Effects.Signal'. +logAndThrowsErr :: (MonadEffect Logging m, Throws e m, HasCallStack) => Text -> e -> m a +logAndThrowsErr msg err = logError msg >> throwSignal err + +-- | Log an error and throw a generic exception containing the text of the error message. +logAndThrowGeneric :: (MonadEffect Logging m, MonadThrow m, HasCallStack) => Text -> m a +logAndThrowGeneric msg = logError msg >> throwM (GenericException msg) + +-- | Log a stripped-down version of the logs to the console. +-- Only contains the message and the severity. +logMessagesToStdout :: MonadIO m => EffectHandler Logging m a -> m a +logMessagesToStdout = handleLogging (\Log{..} -> putText (pshow logLevel <> ": " <> logMessage)) + +-- | Log everything to the console. Uses the 'Show' instance for 'Log'. +logRawToStdout :: MonadIO m => EffectHandler Logging m a -> m a +logRawToStdout = handleLogging print + +-- | Discard the logs. +muteLogs :: Monad m => EffectHandler Logging m a -> m a +muteLogs = handleLogging (const (return ())) + +-- | Use the given function to transform and possibly discard logs. +witherLogs :: MonadEffect Logging m => (Log -> m (Maybe Log)) -> EffectHandler Logging m a -> m a +witherLogs f = handleLogging $ f >=> maybe (return ()) logEffect + +-- | Only let through logs that satisfy the given predicate. +filterLogs :: MonadEffect Logging m => (Log -> Bool) -> EffectHandler Logging m a -> m a +filterLogs f = witherLogs (\l -> return $ if f l then Just l else Nothing) + +-- | Transform logs with the given function. +mapLogs :: MonadEffect Logging m => (Log -> m Log) -> EffectHandler Logging m a -> m a +mapLogs f = witherLogs ((Just <$>) . f) + +-- | Filter out logs that are comming from below a certain depth. +logIfDepthLessThan :: MonadEffect Logging m => Int -> EffectHandler Logging m a -> m a +logIfDepthLessThan n = logIfDepth (< n) + +-- | Filter logs whose depth satisfies the given predicate. +logIfDepth :: MonadEffect Logging m => (Int -> Bool) -> EffectHandler Logging m a -> m a +logIfDepth cond = filterLogs (\Log{..} -> cond (length logContext)) + +-- | For each log, add it's message to the logs breadcrumb list. This is useful so you don't have +-- to manually add crumbs. +messagesToCrumbs :: (MonadIO m, MonadEffect Logging m) => EffectHandler Logging m a -> m a +messagesToCrumbs = mapLogs $ \l@Log{..} -> do + time <- liftIO getCurrentTime + let cat = Data.Text.intercalate "." (fmap getContext logContext) + return (l { logCrumbs = logCrumbs ++ [Crumb time (Just logMessage) cat (DefaultCrumb [])] }) + +-- | Each log that passes through will get all of the crumbs of the previous logs added. +-- If, for example, you're writing a web server, you might want to have this handler over the +-- request handler so that if an error occurs you can see all the steps that happened before it, +-- during the handling of that request. +collectCrumbs :: MonadEffect Logging m => EffectHandler Logging (StateT [Crumb] m) a -> m a +collectCrumbs = flip evalStateT [] . mapLogs (\l@Log{..} -> do + crumbs <- get + let newCrumbs = crumbs ++ logCrumbs + put newCrumbs + return (l { logCrumbs = newCrumbs })) + +-- | Add a user to every log. +addUserToLogs :: MonadEffect Logging m => LogUser -> EffectHandler Logging m a -> m a +addUserToLogs user = mapLogs (\l -> return (l { logUser = Just user })) + +-- | Add a crumb to every log. +addCrumbToLogs :: MonadEffect Logging m => Crumb -> EffectHandler Logging m a -> m a +addCrumbToLogs crumb = mapLogs (\l -> return (l { logCrumbs = logCrumbs l ++ [crumb] })) + +-- | Attach an arbitrary 'ByteString' to every log. Typically you want to use this handler on +-- 'logX' functions directly like @setDataTo "some data" (logInfo "some info")@ +setDataTo :: MonadEffect Logging m => ByteString -> EffectHandler Logging m a -> m a +setDataTo bs = mapLogs (\l -> return (l { logData = bs })) + +-- | Attach an arbitrary value to every log using it's 'ToJSON' instance. +-- Typically you want to use this handler on 'logX' functions directly like +-- @setDataToJsonOf 123 (logInfo "some info")@ +setDataToJsonOf :: (MonadEffect Logging m, ToJSON v) => v -> EffectHandler Logging m a -> m a +setDataToJsonOf = setDataTo . toS . encode + +-- | Attach an arbitrary value to every log using it's 'Show' instance. +-- Typically you want to use this handler on 'logX' functions directly like +-- @setDataToShowOf 123 (logInfo "some info")@ +setDataToShowOf :: (MonadEffect Logging m, Show v) => v -> EffectHandler Logging m a -> m a +setDataToShowOf = setDataTo . pshow + +-- | Add the current time to every log. +setTimestampToNow :: (MonadEffect Logging m, MonadIO m) => EffectHandler Logging m a -> m a +setTimestampToNow = mapLogs $ \l -> do + time <- liftIO getCurrentTime + return (l { logTimestamp = Just time }) + +-- | Print out the logs in rich format. Truncates at the given length. +-- Logs will contain: message, timestamp, data, user and the call stack. +prettyPrintSummary :: MonadIO m => Int -> EffectHandler Logging m a -> m a +prettyPrintSummary trunc h = do + lock <- liftIO (newMVar ()) + flip handleLogging h $ \Log{..} -> liftIO $ withMVar lock $ \_ -> do + putText "┌" + putText ("| " <> pshow logLevel <> " Log") + putText ("| Message: " <> logMessage) + putText ("| Time: " <> pshow logTimestamp) + putText ("| Data: " <> toS (BS.take trunc logData) <> "...") + when (isJust logUser) $ do + let Just LogUser{..} = logUser + putText ("| User: " <> logUserId <> ", " + <> fromMaybe " - " logUserEmail <> ", " + <> fromMaybe " - " logUserUsername) + putText ("| Stack: " <> toS (BS.take trunc (pshow logCallStack)) <> "...") + putText "└" diff --git a/src/Control/Effects/Logging/Sentry.hs b/src/Control/Effects/Logging/Sentry.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effects/Logging/Sentry.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE TupleSections, OverloadedLists, ScopedTypeVariables, RecordWildCards #-} +module Control.Effects.Logging.Sentry where + +import Prelude (String) +import Interlude +import qualified Data.Vector as Vector +import qualified Data.HashMap.Strict as Map +import Text.ParserCombinators.ReadP +import Data.UUID +import Control.Lens hiding ((.=), Level, Context) + +import Data.Aeson.Types (Value(..)) +import Data.Aeson (toJSON, object, (.=)) +import Network.Wreq + +import Data.Time.ISO8601 +import Data.Time (getCurrentTime) + +import Control.Effects.Logging + +-- import Control.Effects + +tagToPair :: Tag -> (String, String) +tagToPair (Tag t) = (toS t, "") + +levelToSentry :: Level -> Text +levelToSentry Fatal = "fatal" +levelToSentry Error = "error" +levelToSentry Warning = "warning" +levelToSentry Info = "info" +levelToSentry Debug = "debug" + +data SentryService = SentryService { serviceEndpoint :: Text + , servicePublicKey :: Text + , serviceSecretKey :: Text } + deriving (Eq, Ord, Read, Show) + +alphaNum :: ReadP Char +alphaNum = satisfy isAlphaNum + +sentryServiceFromDSN :: Text -> SentryService +sentryServiceFromDSN txt = fst $ fromMaybe (error "Failed to parse DSN") + (listToMaybe (readP_to_S parser (toS txt))) + where parser = do + protocol <- many1 alphaNum + void $ string "://" + public <- many1 alphaNum + void $ char ':' + secret <- many1 alphaNum + void $ char '@' + host <- many1 (satisfy (const True)) + void $ char '/' + projId <- many1 (satisfy isDigit) + eof + return (SentryService (toS $ protocol <> "://" <> host <> "/api/" <> projId <> "/store/") + (toS public) + (toS secret)) + +contextToFrame :: Context -> Value +contextToFrame (Context ctx) = object ["module" .= String ctx] + +contextToFrames :: [Context] -> Value +contextToFrames ctxs = object + ["frames" .= Array (Vector.fromList (reverse (top : fmap contextToFrame ctxs)))] + where top = object ["module" .= String "top layer"] + +currentWreqOptions :: Text -> Text -> Text -> Network.Wreq.Options +currentWreqOptions stamp public secret = + defaults & header "X-Sentry-Auth" .~ [ + "Sentry sentry_version=7,\ + \sentry_client=0.1,\ + \sentry_timestamp=" <> pshow stamp <> ",\ + \sentry_key=" <> toS public <> ",\ + \sentry_secret=" <> toS secret] + & header "Content-Type" .~ ["application/json"] + +addInterface :: ToJSON a => Text -> Maybe a -> [(Text, Value)] -> [(Text, Value)] +addInterface _ Nothing is = is +addInterface name (Just a) is = (name, toJSON a) : is + +logToSentry :: (MonadIO m, MonadRandom m) => SentryService -> EffectHandler Logging m a -> m a +logToSentry svc = handleLogging $ \Log{..} -> do + uuid :: UUID <- getRandom + time <- liftIO getCurrentTime + let stamp = toS $ formatISO8601 time + let opts = currentWreqOptions stamp (servicePublicKey svc) (serviceSecretKey svc) + let evId = filter (/= '-') (pshow uuid :: String) + let frames = contextToFrames logContext + let crumbs = Array (Vector.fromList (fmap toJSON logCrumbs)) + let message = Object (Map.fromList ( + [ ("event_id", String (toS evId)) + , ("message", String logMessage) + , ("timestamp", String stamp) + , ("level", String (levelToSentry logLevel)) + , ("logger", String "logger") + , ("platform", String "haskell") + , ("fingerprint", Array [String stamp]) + , ("extra", object [("data", String (toS logData))]) + , ("sentry.interfaces.Breadcrumbs", crumbs) + , ("sentry.interfaces.Stacktrace", frames) ] + & addInterface "sentry.interfaces.User" logUser)) + void $ liftIO $ forkIO $ void $ postWith opts (toS $ serviceEndpoint svc) message diff --git a/src/Interlude.hs b/src/Interlude.hs new file mode 100644 --- /dev/null +++ b/src/Interlude.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE FlexibleContexts #-} +module Interlude (module X, module Interlude) where + +import Prelude as X hiding (print) +import qualified Prelude +import Data.ByteString as X (ByteString) +import Control.Monad.IO.Class as X +import Control.Monad.Catch as X +import Data.Proxy as X +import Control.Monad.State as X +import Data.Function as X +import Data.Semigroup as X +import Data.String.Conv as X +import Control.Concurrent.MVar as X +import Data.Maybe as X +import Data.Text as X (Text) +import Data.Aeson as X hiding (Error) +import Control.Monad.Random as X +import Data.Char as X +import Control.Concurrent as X + +pshow :: (StringConv String b, Show a) => a -> b +pshow = toS . show + +putText :: MonadIO m => Text -> m () +putText = print + +print :: (Show a, MonadIO m) => a -> m () +print = liftIO . Prelude.print . show diff --git a/test/Module1.hs b/test/Module1.hs new file mode 100644 --- /dev/null +++ b/test/Module1.hs @@ -0,0 +1,17 @@ +module Module1 where + +import Interlude + +import Control.Effects.Logging +import Control.Effects.Logging.Sentry + +main :: IO () +main = logToSentry (sentryServiceFromDSN "http://2b34b80ce7804b28b206e04ac633da02:b7c32aaa5e764565a4e6b7765164cdea@sentry.deegeet.al/4") $ + collectCrumbs $ messagesToCrumbs $ do + layerLogs (Context "layer1") $ do + logInfo "Hello from layer1" + addUserToLogs (LogUser "id" (Just "email@email.com") (Just "username")) $ layerLogs (Context "layer2") $ do + logInfo "Hello from layer2" + setDataToShowOf (Just (5 :: Int)) $ logInfo "This message has a data" + setDataToJsonOf [1, 2, 3 :: Int] $ logInfo "This message has data but is in layer1" + logWarning "No layers but should still have crumbs" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"