log-utils (empty) → 0.2.2
raw patch · 10 files changed
+648/−0 lines, 10 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, cmdargs, data-default, exceptions, hpqtypes, http-types, invariant, kontra-config, lifted-base, log, monad-control, random, text, time, transformers, transformers-base, unjson, vector, wai, warp
Files
- CHANGELOG.md +8/−0
- LICENSE +30/−0
- README.md +3/−0
- Setup.hs +2/−0
- inc/SQL.hs +183/−0
- log-fetcher/LogFetcher.hs +156/−0
- log-server/Handlers.hs +77/−0
- log-server/LogServer.hs +50/−0
- log-server/LogServerConf.hs +40/−0
- log-utils.cabal +99/−0
+ CHANGELOG.md view
@@ -0,0 +1,8 @@+# log-utils 0.2.2+* upgrade to log-0.5.4++# log-utils 0.2.1+* convert to hpqtypes-1.5++# log-utils 0.2+* initial release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Scrive++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 Scrive 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,3 @@+# log-utils [](https://hackage.haskell.org/package/log-utils) [](http://travis-ci.org/scrive/log-utils)++Utils for working with logs.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ inc/SQL.hs view
@@ -0,0 +1,183 @@++module SQL (+ runDB+ , fetchComponents+ , LogRequest(..)+ , defLogLimit+ , parseLogRequest+ , foldChunkedLogs+ ) where++import Control.Applicative+import Control.Exception (ErrorCall(..))+import Control.Monad.Base+import Control.Monad.Catch+import Data.Aeson+import Data.Functor.Invariant+import Data.List+import Data.Maybe+import Data.Monoid+import Data.Monoid.Utils+import Data.Unjson+import Data.Word+import Database.PostgreSQL.PQTypes+import Log+import Prelude+import System.Random+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text as T++runDB :: (MonadBase IO m, MonadMask m) => ConnectionSourceM m -> DBT m a -> m a+runDB cs = runDBT cs def {+ tsPermissions = ReadOnly+}++----------------------------------------++fetchComponents :: MonadDB m => m [T.Text]+fetchComponents = do+ runSQL_ "SELECT DISTINCT component FROM logs ORDER BY component"+ fetchMany runIdentity++----------------------------------------++data LogRequest = LogRequest {+ lrComponent :: !(Maybe T.Text)+, lrFrom :: !(Maybe UTCTime)+, lrTo :: !(Maybe UTCTime)+, lrWhere :: !(Maybe (RawSQL ()))+, lrLimit :: !(Maybe Int)+, lrLast :: !Bool+}++defLogLimit :: Int+defLogLimit = 1000++parseLogRequest :: MonadThrow m => BSL.ByteString -> m LogRequest+parseLogRequest s = case eitherDecode s of+ Left err -> throwE $ "aeson:" <+> err+ Right value -> case parse unjsonLogRequest value of+ Result req [] -> return req+ Result _ errs -> throwE . unlines $ map show errs+ where+ throwE = throwM . ErrorCall . ("parseLogRequest: " ++)++unjsonLogRequest :: UnjsonDef LogRequest+unjsonLogRequest = objectOf $ LogRequest+ <$> fieldOpt "component"+ lrComponent+ "system component"+ <*> fieldOpt "from"+ lrFrom+ "fetch logs since"+ <*> fieldOpt "to"+ lrTo+ "fetch logs until"+ <*> fieldOptBy "where"+ lrWhere+ "sql where clause"+ -- This conversion is obviously unsafe, but the assumption+ -- is that we will use database user with constrained access+ -- rights, so it shouldn't be a problem.+ (invmap (`rawSQL` ()) unRawSQL unjsonAeson)+ <*> fieldOpt "limit"+ lrLimit+ ("limit of logs (defaults to " <> T.pack (show defLogLimit) <> ")")+ <*> field "last"+ lrLast+ "if true, fetch <LIMIT> last logs, otherwise first ones"++----------------------------------------++foldChunkedLogs :: (MonadBase IO m, MonadDB m, MonadMask m)+ => LogRequest+ -> (acc -> m acc)+ -> acc+ -> (acc -> QueryResult (UTCTime, LogMessage) -> m acc)+ -> m acc+foldChunkedLogs req betweenChunks initAcc f = do+ uuid :: Word32 <- liftBase randomIO+ -- Stream logs from the database using a cursor.+ let cursor = "log_fetcher_" <> unsafeSQL (show uuid)+ declare = runSQL_ $ smconcat [+ "DECLARE"+ , cursor+ , "NO SCROLL CURSOR FOR"+ , sqlSelectLogs req+ ]+ close = runSQL_ $ "CLOSE" <+> cursor+ bracket_ declare close $ loop cursor True initAcc+ where+ loop cursor firstPass acc = do+ n <- runSQL $ "FETCH FORWARD 100 FROM" <+> cursor+ if n == 0+ then return acc+ else do+ acc' <- if firstPass+ then return acc+ else betweenChunks acc+ queryResult+ >>= f acc' . fmap fetchLog+ >>= loop cursor False++sqlSelectLogs :: LogRequest -> SQL+sqlSelectLogs LogRequest{..} = smconcat [+ "WITH filtered_logs AS ("+ , "SELECT" <+> concatComma (unique $ logsFields ++ orderFields)+ , "FROM logs"+ , "WHERE" <+> (mintercalate " AND " $ catMaybes [+ Just "TRUE"+ , ("time >" <?>) <$> lrFrom+ , ("time <=" <?>) <$> lrTo+ , ("component =" <?>) <$> lrComponent+ , raw <$> lrWhere+ ])+ , "ORDER BY" <+> (concatComma $ map (<+> orderType) orderFields)+ -- Limit the amount to be fetched. To be honest, browsers+ -- will probably blow up when they receive 10k records anyway.+ , "LIMIT" <?> fromMaybe defLogLimit lrLimit+ , ")"+ , "SELECT" <+> concatComma logsFields+ , "FROM filtered_logs"+ , "ORDER BY" <+> concatComma orderFields+ ]+ where+ unique :: Ord a => [a] -> [a]+ unique = map head . group . sort++ concatComma :: [RawSQL ()] -> SQL+ concatComma = mintercalate ", " . map raw++ orderFields :: [RawSQL ()]+ orderFields = [+ "time"+ , "insertion_time"+ , "insertion_order"+ ]+ orderType :: RawSQL ()+ orderType = if lrLast+ then "DESC"+ else "ASC"++ logsFields :: [RawSQL ()]+ logsFields = [+ "insertion_time"+ , "time"+ , "level"+ , "component"+ , "domain"+ , "message"+ , "data"+ ]++fetchLog :: (UTCTime, UTCTime, T.Text, T.Text, Array1 T.Text, T.Text, JSONB Value)+ -> (UTCTime, LogMessage)+fetchLog (insertion_time, time, level, component, Array1 domain, message, JSONB data_) =+ (insertion_time, LogMessage {+ lmComponent = component+ , lmDomain = domain+ , lmTime = time+ , lmLevel = readLogLevel level+ , lmMessage = message+ , lmData = data_+ })
+ log-fetcher/LogFetcher.hs view
@@ -0,0 +1,156 @@+module Main where++import Control.Applicative+import Control.Concurrent+import Control.Exception (ErrorCall(..))+import Control.Monad+import Control.Monad.Base+import Control.Monad.Catch+import Control.Monad.Trans.Reader+import Data.Aeson+import Data.Default+import Data.Function+import Data.IORef+import Data.Maybe+import Data.Time+import Database.PostgreSQL.PQTypes+import Log.Data+import Prelude+import System.Console.CmdArgs.Implicit hiding (def)+import System.Environment+import qualified Data.Foldable as F+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.Traversable as T++import SQL++data CmdArgument = Logs {+ database :: String+, component :: Maybe String+, from :: Maybe String+, to :: Maybe String+, where_ :: Maybe String+, limit :: Maybe Int+, last_ :: Bool+, follow :: Bool+} | Components {+ database :: String+} deriving (Data, Typeable)++cmdLogs :: CmdArgument+cmdLogs = Logs {+ database = defDatabase+, component = Nothing+ &= name "c"+ &= help "system component (optional)"+ &= typ "COMPONENT"+, from = Nothing+ &= name "f"+ &= help ("fetch logs since (optional, format: " ++ timeFormat ++ ")")+ &= typ "TIMESTAMP"+, to = Nothing+ &= name "t"+ &= help ("fetch logs until (optional, format: " ++ timeFormat ++ ")")+ &= typ "TIMESTAMP"+, where_ = Nothing+ &= name "w"+ &= help "WHERE clause to further filter logs (optional)"+ &= typ "SQL"+, limit = Nothing+ &= name "l"+ &= help ("limit of fetched logs (optional, default: " ++ show defLogLimit ++ ")")+, last_ = False+ &= help "fetch <LIMIT> last logs instead of first ones (optional)"+, follow = False+ &= help "output logs as they are recorded (with 5 seconds delay). If set, implicitly enables 'last' and overwrites 'to' (optional)"+} &= help "Fetch the list of log messages fulfilling set criteria"+ where+ timeFormat = "'YYYY-MM-DD hh:mm:ss'"++cmdComponents :: CmdArgument+cmdComponents = Components {+ database = defDatabase+} &= help "Fetch the list of available components"++defDatabase :: String+defDatabase = ""+ &= name "d"+ &= help "database connection info (required)"+ &= typ "CONNINFO"++----------------------------------------++data LogsSt = LogsSt {+ lsLogNumber :: !(IORef Int)+}++type LogsM = ReaderT LogsSt (DBT IO)++main :: IO ()+main = do+ progName <- getProgName+ cmd <- cmdArgs $ modes [cmdComponents, cmdLogs] &= program progName+ let cs = simpleSource $ def { csConnInfo = T.pack $ database cmd }+ case cmd of+ Components{..} -> runDB (unConnectionSource cs) $ fetchComponents >>= mapM_ (liftBase . T.putStrLn)+ Logs{..} -> runDB (unConnectionSource cs) $ do+ utcFrom <- T.mapM parseTime_ from+ utcTo <- T.mapM parseTime_ to+ logRq <- parseLogRequest . encode . object $ catMaybes [+ fmap ("component" .=) component+ , fmap ("from" .=) utcFrom+ , fmap ("to" .=) utcTo+ , fmap ("where" .=) where_+ , fmap ("limit" .=) limit+ , Just $ "last" .= last_+ ]+ initSt <- LogsSt <$> liftBase (newIORef 0)+ (`runReaderT` initSt) . (`finally` printSummary) $ if not follow+ then printLogs logRq+ else do+ -- When following logs, start by fetching all logs recorded+ -- until 5 seconds ago and then each second fetch logs recorded+ -- between now - 6s and now - 5s. The delay is needed so that+ -- we don't "lose" logs that might have been recorded with a+ -- slight delay (5 seconds should be plenty of time to archive+ -- that).+ initRq <- liftBase $ getCurrentTime+ >>= \now -> return logRq {+ lrTo = Just $ fiveSecondsBefore now+ , lrLast = True+ }+ (`fix` initRq) $ \loop rq -> do+ printLogs rq+ liftBase $ threadDelay 1000000+ now <- liftBase getCurrentTime+ loop $ rq {+ lrFrom = lrTo rq+ , lrTo = Just $ fiveSecondsBefore now+ , lrLimit = Just maxBound+ }+ where+ fiveSecondsBefore :: UTCTime -> UTCTime+ fiveSecondsBefore t = (-5) `addUTCTime` t++ printSummary :: LogsM ()+ printSummary = do+ n <- liftBase . readIORef =<< asks lsLogNumber+ liftBase $ putStrLn $ show n ++ " log messages fetched."++ printLogs :: LogRequest -> LogsM ()+ printLogs logRq = foldChunkedLogs logRq return () $ \() qr -> do+ liftBase . (`modifyIORef'` (+ ntuples qr)) =<< asks lsLogNumber+ liftBase . F.forM_ qr $ \(t, lm) -> T.putStrLn $ showLogMessage (Just t) lm++ parseTime_ :: MonadThrow m => String -> m UTCTime+ parseTime_ s = case mtime of+ Just time -> return time+ Nothing -> throwM . ErrorCall $ "parseTime_: invalid value: " ++ s+ where+ mtime = msum [+ parse "%Y-%m-%d" s+ , parse "%Y-%m-%d %H:%M" s+ , parse "%Y-%m-%d %H:%M:%S%Q" s+ ]+ parse = parseTimeM True defaultTimeLocale
+ log-server/Handlers.hs view
@@ -0,0 +1,77 @@+module Handlers (+ apiError+ , appHandler+ ) where++import Control.Applicative+import Control.Exception (SomeException)+import Control.Monad.Base+import Data.Aeson+import Data.ByteString (ByteString)+import Data.Monoid.Utils+import Database.PostgreSQL.PQTypes+import Log+import Network.HTTP.Types+import Network.Wai+import Prelude+import qualified Data.ByteString.Builder as BSB+import qualified Data.Foldable as F+import qualified Data.Vector as V++import SQL++type HandlerM = DBT (LogT IO)+type HandlerRunner = forall r. HandlerM r -> IO r++data HandlerEnv = HandlerEnv {+ heRunHandler :: !HandlerRunner+, heRequest :: !Request+, heRespond :: !(Response -> IO ResponseReceived)+}++apiError :: SomeException -> Response+apiError = responseLBS badRequest400 [(hContentType, jsonContentType)] . encode . f+ where+ f err = object ["error" .= show err]++jsonContentType :: ByteString+jsonContentType = "application/json"++----------------------------------------++appHandler :: HandlerRunner -> Application+appHandler runHandler rq respond = case pathInfo rq of+ -- We could use wai-routes for that, but there really is no point+ -- as these routes are very simple and won't get more complicated.+ ["api", "components"] | isGET -> handleApiComponents env+ ["api", "logs"] | isPOST -> handleApiLogs env+ _ -> respond $ responseLBS notFound404 [] "Nothing is here."+ where+ isGET = requestMethod rq == methodGet+ isPOST = requestMethod rq == methodPost++ env = HandlerEnv {+ heRunHandler = runHandler+ , heRequest = rq+ , heRespond = respond+ }++handleApiComponents :: HandlerEnv -> IO ResponseReceived+handleApiComponents HandlerEnv{..} = do+ components <- heRunHandler $ V.fromList . map String <$> fetchComponents+ heRespond . responseOk . encode $ object ["components" .= Array components]+ where+ responseOk = responseLBS ok200 [(hContentType, jsonContentType)]++handleApiLogs :: HandlerEnv -> IO ResponseReceived+handleApiLogs HandlerEnv{..} = do+ logRq <- parseLogRequest =<< lazyRequestBody heRequest+ heRespond . responseOk $ \write _flush -> heRunHandler $ do+ liftBase $ write "{\"logs\":["+ foldChunkedLogs logRq (\() -> liftBase $ write ",") () $ \() qr -> liftBase $ do+ write . mintercalate (BSB.lazyByteString ",")+ . map (BSB.lazyByteString . encode)+ $ F.toList qr+ liftBase $ write "]}"+ where+ responseOk = responseStream ok200 [(hContentType, jsonContentType)]
+ log-server/LogServer.hs view
@@ -0,0 +1,50 @@+module Main where++import Configuration+import Control.Exception.Lifted+import Control.Monad.Base+import Control.Monad.Catch (MonadMask)+import Data.Default+import Data.String+import Database.PostgreSQL.PQTypes+import Log+import Log.Backend.StandardOutput+import Network.Wai+import Network.Wai.Handler.Warp+import Prelude++import Handlers+import LogServerConf+import SQL++type MainM = LogT IO++main :: IO ()+main = do+ conf <- readConfig putStrLn "log_server.conf"+ withSimpleStdOutLogger $ \logger -> runLogger logger $ do+ pool <- liftBase $ poolSource (def {+ csConnInfo = lscDBConfig conf+ }) 1 10 10+ startServer logger pool conf+ where+ runLogger :: Logger -> LogT m r -> m r+ runLogger = runLogT "log-server"++ startServer :: Logger -> ConnectionSource '[MonadBase IO, MonadMask]+ -> LogServerConf -> LogT IO ()+ startServer logger pool LogServerConf{..} = do+ let ss = setHost (fromString lscBindHost)+ . setPort (fromIntegral lscBindPort)+ . setOnExceptionResponse apiError+ . setOnException (handleServerError logger)+ $ defaultSettings+ liftBase . runSettings ss $ appHandler+ $ runLogger logger . runDB (unConnectionSource pool)++ handleServerError :: Logger -> Maybe Request -> SomeException -> IO ()+ handleServerError logger rq err = runLogger logger $ do+ logAttention "Server error" $ object [+ "request" .= show rq+ , "error" .= show err+ ]
+ log-server/LogServerConf.hs view
@@ -0,0 +1,40 @@+module LogServerConf (+ LogServerConf(..)+ ) where++import Control.Applicative+import Data.Default+import Data.Monoid+import Data.Unjson+import Data.Word+import Prelude+import qualified Data.Text as T++data LogServerConf = LogServerConf {+ lscBindHost :: !String+, lscBindPort :: !Word16+, lscDBConfig :: !T.Text+}++instance Unjson LogServerConf where+ unjsonDef = objectOf $ LogServerConf+ <$> field "bind_ip"+ lscBindHost+ ("IP to listen on, defaults to 127.0.0.1 (see "+ <> "http://hackage.haskell.org/package/warp/docs/"+ <> "Network-Wai-Handler-Warp.html#t:HostPreference"+ <> " for more information)")+ <*> field "bind_port"+ lscBindPort+ "Port to listen on"+ <*> fieldBy "database"+ lscDBConfig+ "Database connection string"+ unjsonAeson++instance Default LogServerConf where+ def = LogServerConf {+ lscBindHost = "127.0.0.1"+ , lscBindPort = 7000+ , lscDBConfig = "user='kontra' password='kontra' dbname='kontrakcja'"+ }
+ log-utils.cabal view
@@ -0,0 +1,99 @@+name: log-utils+version: 0.2.2+synopsis: Utils for working with logs+description: Two utilities for working with logs:+ log-server and log-fetcher.+homepage: https://github.com/scrive/log-utils+license: BSD3+license-file: LICENSE+author: Scrive AB+maintainer: Andrzej Rybczak <andrzej@scrive.com>+copyright: Scrive AB+category: Data+build-type: Simple+cabal-version: >=1.10+tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1+extra-source-files: CHANGELOG.md,+ README.md++source-repository head+ type: git+ location: https://github.com/scrive/log-utils.git++executable log-server+ hs-source-dirs: inc log-server+ ghc-options: -Wall -O2 -funbox-strict-fields -threaded+ main-is: LogServer.hs+ other-modules: Handlers+ LogServerConf+ SQL++ build-depends: base >= 4.6 && < 5+ , aeson >= 0.7+ , bytestring+ , data-default+ , exceptions >= 0.6+ , hpqtypes >= 1.5+ , http-types+ , invariant+ , kontra-config+ , lifted-base+ , log >= 0.5.4+ , monad-control+ , random+ , text+ , transformers-base+ , unjson+ , vector+ , wai+ , warp++ default-language: Haskell2010++ default-extensions: DataKinds,+ DeriveDataTypeable,+ FlexibleContexts,+ LambdaCase,+ NoImplicitPrelude,+ OverloadedStrings,+ RankNTypes,+ RecordWildCards,+ ScopedTypeVariables,+ TypeOperators++executable log-fetcher+ hs-source-dirs: inc log-fetcher+ ghc-options: -Wall -O2 -funbox-strict-fields -threaded+ main-is: LogFetcher.hs+ other-modules: SQL++ build-depends: base >= 4.6 && < 5+ , aeson >= 0.7+ , bytestring+ , cmdargs+ , data-default+ , exceptions >= 0.6+ , hpqtypes >= 1.5+ , invariant+ , lifted-base+ , log >= 0.4+ , monad-control+ , random+ , text+ , time >= 1.5+ , transformers+ , transformers-base+ , unjson++ default-language: Haskell2010++ default-extensions: DataKinds,+ DeriveDataTypeable,+ FlexibleContexts,+ LambdaCase,+ NoImplicitPrelude,+ OverloadedStrings,+ RankNTypes,+ RecordWildCards,+ ScopedTypeVariables,+ TypeOperators