From 76860ce667a40b69866241c1bf0b8ab76f50d1d2 Mon Sep 17 00:00:00 2001 From: Igor Pashev Date: Mon, 13 Jun 2016 15:48:13 +0800 Subject: Version 0.1.0 --- src/Application.hs | 84 +++++++++++++++++++++++++++++++++++++++++++++++++ src/LogFormat.hs | 40 ++++++++++++++++++++++++ src/Main.hs | 68 ++++++++++++++++++++++++++++++++++++++++ src/Server.hs | 92 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 284 insertions(+) create mode 100644 src/Application.hs create mode 100644 src/LogFormat.hs create mode 100644 src/Main.hs create mode 100644 src/Server.hs (limited to 'src') diff --git a/src/Application.hs b/src/Application.hs new file mode 100644 index 0000000..63aa258 --- /dev/null +++ b/src/Application.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Application ( + app +) where + +import Prelude hiding (id) + +import Control.Monad.Trans (liftIO) +import Data.Aeson (ToJSON) +import Data.Default.Class (def) +import Data.List (sort) +import Data.Pool (Pool, withResource) +import Data.Text.Lazy (Text) +import Database.MySQL.Simple (Connection, query_) +import GHC.Generics (Generic) +import Network.HTTP.Types (notFound404) +import Network.Wai (Application, Middleware) +import Network.Wai.Middleware.RequestLogger (Destination(Handle), + mkRequestLogger, RequestLoggerSettings(destination, outputFormat), + OutputFormat(CustomOutputFormat)) +import Network.Wai.Middleware.Static (addBase, hasPrefix, staticPolicy, (>->)) +import System.IO (stderr) +import Web.Scotty (ScottyM, ActionM, middleware, json, file, get, + status, text, param, scottyApp) +import qualified Data.HashMap.Lazy as HM + +import LogFormat (logFormat) + +type Pools = HM.HashMap Text (Pool Connection) + +app :: Pools -> FilePath -> IO Application +app ps f = do + logger <- mkRequestLogger def{ destination = Handle stderr + , outputFormat = CustomOutputFormat logFormat } + scottyApp (myProcess ps logger f) + +myProcess :: Pools -> Middleware -> FilePath -> ScottyM () +myProcess ps logger dataDir = do + let + index_html = dataDir ++ "/" ++ "index.html" + + middleware logger + + middleware $ staticPolicy (hasPrefix "static" >-> addBase dataDir) + get "/" $ file index_html + get "/index.html" $ file index_html + + get "/serverlist.json" $ json (sort $ HM.keys ps) + get "/server/:server/processlist.json" $ apiGetProcesses ps + +data Process = Process { + id :: Int + , user :: Text + , host :: Text + , db :: Maybe Text + , command :: Text + , time :: Int + , state :: Text + , info :: Text +} deriving (Generic) +instance ToJSON Process + +apiGetProcesses :: Pools -> ActionM () +apiGetProcesses ps = do + server <- param "server" + case HM.lookup server ps of + Nothing -> status notFound404 >> text server + Just p -> do + res <- withDB p $ \c -> + query_ c "SELECT \ + \id, user, host, db, command, time, state, info \ + \FROM information_schema.processlist \ + \WHERE info IS NOT NULL \ + \ORDER BY time DESC, id ASC" + json $ map (\(id, user, host, db, command, time, state, info) -> Process {..}) res + +withDB :: Pool Connection -> (Connection -> IO a) -> ActionM a +withDB p a = liftIO $ withResource p (liftIO . a) + diff --git a/src/LogFormat.hs b/src/LogFormat.hs new file mode 100644 index 0000000..51c36c6 --- /dev/null +++ b/src/LogFormat.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} + +module LogFormat ( + logFormat +) where + +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Network.HTTP.Types (Status(statusCode)) +import Network.Wai (Request, httpVersion, requestHeaders, requestMethod, + rawPathInfo, requestHeaderReferer, requestHeaderUserAgent) +import System.Log.FastLogger (LogStr, toLogStr) +import qualified Data.ByteString.Char8 as BS + +-- Sligthly modified Common Log Format. +-- User ID extracted from the From header. +logFormat :: BS.ByteString -> Request -> Status -> Maybe Integer -> LogStr +logFormat t req st msize = "" + <> toLogStr (fromMaybe "-" $ lookup "X-Forwarded-For" headers) + <> " - " + <> toLogStr (fromMaybe "-" $ lookup "From" headers) + <> " [" + <> toLogStr t + <> "] \"" + <> toLogStr (requestMethod req) + <> " " + <> toLogStr (rawPathInfo req) + <> " " + <> toLogStr (show $ httpVersion req) + <> "\" " + <> toLogStr (show $ statusCode st) + <> " " + <> toLogStr (maybe "-" show msize) + <> " \"" + <> toLogStr (fromMaybe "" $ requestHeaderReferer req) + <> "\" \"" + <> toLogStr (fromMaybe "" $ requestHeaderUserAgent req) + <> "\"\n" + where headers = requestHeaders req + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..494faba --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Main ( + main +) where + +import Data.ByteString.Char8 (pack) +import Data.Either.Utils (forceEither) +import Data.Maybe (fromJust) +import Data.Version (showVersion) +import Database.MySQL.Base (ConnectInfo(..)) +import Database.MySQL.Base.Types (Option(ReadDefaultFile, ReadDefaultGroup)) +import Paths_mywatch (getDataDir, version) -- from cabal +import System.Environment (getArgs) +import Text.InterpolatedString.Perl6 (qc) +import qualified Data.ConfigFile as Cf +import qualified System.Console.Docopt.NoTH as O + +import Server (server) + +usage :: IO String +usage = do + dataDir <- getDataDir + return $ + "mywatch " ++ showVersion version + ++ " view queries on many MySQL servers" ++ [qc| + +Usage: + mywatch [options] MYCNF + +Options: + + -d, --datadir=DIR Data directory including static files [default: {dataDir}] + + -s, --socket=SOCK Listen on this UNIX-socket [default: /tmp/mywatch.sock] + -p, --port=PORT Instead of UNIX-socket, listen on this TCP port (localhost) + + -h, --help Show this message + +|] + +main :: IO() +main = do + doco <- O.parseUsageOrExit =<< usage + args <- O.parseArgsOrExit doco =<< getArgs + if args `O.isPresent` O.longOption "help" + then putStrLn $ O.usage doco + else do + let + file = fromJust $ O.getArg args $ O.argument "MYCNF" + port = O.getArg args $ O.longOption "port" + socket = fromJust $ O.getArg args $ O.longOption "socket" + datadir = fromJust $ O.getArg args $ O.longOption "datadir" + servers <- filter ("client" /=) . Cf.sections . forceEither <$> Cf.readfile Cf.emptyCP file + let + myInfo = map (\g -> ConnectInfo { + connectDatabase = "", + connectHost = "", + connectPassword = "", + connectPath = "", + connectPort = 0, + connectSSL = Nothing, + connectUser = "", + connectOptions = [ ReadDefaultFile file, ReadDefaultGroup (pack g) ] + }) servers + listen = maybe (Right socket) (Left . read) port + server listen myInfo datadir + diff --git a/src/Server.hs b/src/Server.hs new file mode 100644 index 0000000..14ecd9c --- /dev/null +++ b/src/Server.hs @@ -0,0 +1,92 @@ +module Server +( + server +) where + +import Control.Exception.Base (throwIO, catch, bracket) +import Data.Bits ((.|.)) +import Data.ByteString.Lazy (fromStrict) +import Data.List (find) +import Data.Maybe (fromJust) +import Data.Pool (createPool, destroyAllResources) +import Data.Text.Lazy (Text) +import Data.Text.Lazy.Encoding (decodeUtf8) +import Database.MySQL.Base (ConnectInfo(connectOptions)) +import Database.MySQL.Base.Types (Option(ReadDefaultGroup)) +import Network.Socket (socket, setSocketOption, bind, listen, close, + maxListenQueue, getSocketName, inet_addr, Family(AF_UNIX, AF_INET), + SocketType(Stream), SocketOption(ReuseAddr), Socket, SockAddr(SockAddrUnix, + SockAddrInet)) +import Network.Wai.Handler.Warp (Port, defaultSettings, runSettingsSocket) +import System.IO (hPutStrLn, stderr) +import System.IO.Error (isDoesNotExistError) +import System.Posix.Files (removeLink, setFileMode, socketMode, ownerReadMode, + ownerWriteMode, groupReadMode, groupWriteMode) +import qualified Data.HashMap.Lazy as HM +import qualified Database.MySQL.Simple as MySQL + +import Application (app) + +type Listen = Either Port FilePath + + +server :: Listen -> [ConnectInfo] -> FilePath -> IO () +server socketSpec mysqlConnInfo dataDir = + bracket + ( do + sock <- createSocket socketSpec + mysql <- HM.fromList <$> mapM (\c -> do + p <- createPool (MySQL.connect c) MySQL.close 1 60 10 + return (getGroup c, p)) mysqlConnInfo + return (sock, mysql) ) + ( \(sock, mysql) -> do + closeSocket sock + mapM_ destroyAllResources $ HM.elems mysql ) + ( \(sock, mysql) -> do + listen sock maxListenQueue + hPutStrLn stderr $ "Static files from `" ++ dataDir ++ "'" + runSettingsSocket defaultSettings sock =<< app mysql dataDir) + +getGroup :: ConnectInfo -> Text +getGroup ci = decodeUtf8 . getName . fromJust . find isGroup . connectOptions $ ci + where + isGroup (ReadDefaultGroup _) = True + isGroup _ = False + getName (ReadDefaultGroup n) = fromStrict n + getName _ = error "Cannot happen" + + +createSocket :: Listen -> IO Socket +createSocket (Right path) = do + removeIfExists path + sock <- socket AF_UNIX Stream 0 + bind sock $ SockAddrUnix path + setFileMode path $ socketMode + .|. ownerWriteMode .|. ownerReadMode + .|. groupWriteMode .|. groupReadMode + hPutStrLn stderr $ "Listening on UNIX socket `" ++ path ++ "'" + return sock +createSocket (Left port) = do + sock <- socket AF_INET Stream 0 + setSocketOption sock ReuseAddr 1 + addr <- inet_addr "127.0.0.1" + bind sock $ SockAddrInet (fromIntegral port) addr + hPutStrLn stderr $ "Listening on localhost:" ++ show port + return sock + + +closeSocket :: Socket -> IO () +closeSocket sock = do + name <- getSocketName sock + close sock + case name of + SockAddrUnix path -> removeIfExists path + _ -> return () + + +removeIfExists :: FilePath -> IO () +removeIfExists fileName = removeLink fileName `catch` handleExists + where handleExists e + | isDoesNotExistError e = return () + | otherwise = throwIO e + -- cgit v1.2.3