diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# log-utils [![Hackage version](https://img.shields.io/hackage/v/log-utils.svg?label=Hackage)](https://hackage.haskell.org/package/log-utils) [![Build Status](https://secure.travis-ci.org/scrive/log-utils.svg?branch=master)](http://travis-ci.org/scrive/log-utils) + +Utils for working with logs. 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/inc/SQL.hs b/inc/SQL.hs new file mode 100644 --- /dev/null +++ b/inc/SQL.hs @@ -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 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_ + }) diff --git a/log-fetcher/LogFetcher.hs b/log-fetcher/LogFetcher.hs new file mode 100644 --- /dev/null +++ b/log-fetcher/LogFetcher.hs @@ -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 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 diff --git a/log-server/Handlers.hs b/log-server/Handlers.hs new file mode 100644 --- /dev/null +++ b/log-server/Handlers.hs @@ -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)] diff --git a/log-server/LogServer.hs b/log-server/LogServer.hs new file mode 100644 --- /dev/null +++ b/log-server/LogServer.hs @@ -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 + ] diff --git a/log-server/LogServerConf.hs b/log-server/LogServerConf.hs new file mode 100644 --- /dev/null +++ b/log-server/LogServerConf.hs @@ -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'" + } diff --git a/log-utils.cabal b/log-utils.cabal new file mode 100644 --- /dev/null +++ b/log-utils.cabal @@ -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 +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