diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Application.hs | 108 | ||||
| -rw-r--r-- | src/LogFormat.hs | 58 | ||||
| -rw-r--r-- | src/Main.hs | 72 | ||||
| -rw-r--r-- | src/Server.hs | 80 |
4 files changed, 167 insertions, 151 deletions
diff --git a/src/Application.hs b/src/Application.hs index 0b7ca52..5624aec 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -module Application ( - app -) where +module Application + ( app + ) where import Prelude hiding (id) @@ -17,21 +17,23 @@ import qualified Data.HashMap.Lazy as HM import Data.List (sort) import Data.Pool (Pool, withResource) import Data.Text.Lazy (Text) -import Database.MySQL.Simple (Connection, Only (..), execute, query_) +import Database.MySQL.Simple + (Connection, Only(..), execute, query_) import GHC.Generics (Generic) -import Network.HTTP.Types (StdMethod (HEAD), notFound404, notImplemented501, - ok200) +import Network.HTTP.Types + (StdMethod(HEAD), notFound404, notImplemented501, ok200) import Network.Wai (Application, Middleware) import qualified Network.Wai.Middleware.Gzip as Gzip -import Network.Wai.Middleware.RequestLogger (Destination (Handle), - OutputFormat (CustomOutputFormat), - RequestLoggerSettings (destination, outputFormat), - mkRequestLogger) -import Network.Wai.Middleware.Static (addBase, hasPrefix, staticPolicy, (>->)) +import Network.Wai.Middleware.RequestLogger + (Destination(Handle), OutputFormat(CustomOutputFormat), + RequestLoggerSettings(destination, outputFormat), mkRequestLogger) +import Network.Wai.Middleware.Static + ((>->), addBase, hasPrefix, staticPolicy) import System.FilePath.Posix ((</>)) import System.IO (stderr) -import Web.Scotty (ActionM, ScottyM, addroute, delete, file, get, json, - middleware, param, scottyApp, status, text) +import Web.Scotty + (ActionM, ScottyM, addroute, delete, file, get, json, middleware, + param, scottyApp, status, text) import LogFormat (logFormat) @@ -39,37 +41,35 @@ 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 } + logger <- + mkRequestLogger + def + {destination = Handle stderr, outputFormat = CustomOutputFormat logFormat} scottyApp (myProcess ps logger f) -myProcess :: Pools -> Middleware -> FilePath -> ScottyM () +myProcess :: Pools -> Middleware -> FilePath -> ScottyM () myProcess ps logger dataDir = do middleware logger - middleware $ Gzip.gzip Gzip.def {Gzip.gzipFiles = Gzip.GzipCompress} - middleware $ staticPolicy (hasPrefix "static" >-> addBase dataDir) get "/" $ file (dataDir </> "app.html") - get "/serverlist.json" $ json (sort $ HM.keys ps) get "/server/:server/processlist.json" $ apiGetProcessList ps - -- Used by client to see which servers are really allowed by Sproxy addroute HEAD "/server/:server/processlist.json" $ apiCanProcessList ps - delete "/server/:server/process/:id" $ apiKill ps -data Process = Process { - id :: Int - , user :: Text - , host :: Text - , db :: Maybe Text +data Process = Process + { id :: Int + , user :: Text + , host :: Text + , db :: Maybe Text , command :: Text - , time :: Int - , state :: Maybe Text - , info :: Text -} deriving (Generic) + , time :: Int + , state :: Maybe Text + , info :: Text + } deriving (Generic) + instance ToJSON Process apiCanProcessList :: Pools -> ActionM () @@ -77,40 +77,50 @@ apiCanProcessList ps = do server <- param "server" case HM.lookup server ps of Nothing -> status notFound404 >> text server - Just _ -> status ok200 + Just _ -> status ok200 apiKill :: Pools -> ActionM () apiKill ps = do server <- param "server" case HM.lookup server ps of Nothing -> status notFound404 >> text server - Just p -> do + Just p -> do id <- param "id" - if (id :: Int) == 0 then do - [ Only f ] <- withDB p $ \c -> - query_ c "SELECT COUNT(*) FROM information_schema.routines \ + if (id :: Int) == 0 + then do + [Only f] <- + withDB p $ \c -> + query_ + c + "SELECT COUNT(*) FROM information_schema.routines \ \WHERE routine_type = 'PROCEDURE' AND routine_schema = 'mysql' \ \AND routine_name = 'mywatch_kill'" - if (f::Int) > 0 then status ok200 - else status notImplemented501 >> text "mywatch_kill" - else do - _ <- withDB p $ \c -> execute c "CALL mysql.mywatch_kill(?)" [ id ] - status ok200 + if (f :: Int) > 0 + then status ok200 + else status notImplemented501 >> text "mywatch_kill" + else do + _ <- withDB p $ \c -> execute c "CALL mysql.mywatch_kill(?)" [id] + status ok200 apiGetProcessList :: Pools -> ActionM () apiGetProcessList 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 \ + 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 + 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 index b1fc488..2957e97 100644 --- a/src/LogFormat.hs +++ b/src/LogFormat.hs @@ -1,40 +1,40 @@ {-# LANGUAGE OverloadedStrings #-} -module LogFormat ( - logFormat -) where +module LogFormat + ( logFormat + ) where import qualified Data.ByteString.Char8 as BS import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) -import Network.HTTP.Types (Status (statusCode)) -import Network.Wai (Request, httpVersion, rawPathInfo, requestHeaderReferer, - requestHeaderUserAgent, requestHeaders, requestMethod) +import Network.HTTP.Types (Status(statusCode)) +import Network.Wai + (Request, httpVersion, rawPathInfo, requestHeaderReferer, + requestHeaderUserAgent, requestHeaders, requestMethod) import System.Log.FastLogger (LogStr, toLogStr) -- Sligthly modified Combined 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 - +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 index 532bf02..58083a4 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,8 +1,8 @@ {-# LANGUAGE QuasiQuotes #-} -module Main ( - main -) where +module Main + ( main + ) where import Data.ByteString.Char8 (pack) import qualified Data.ConfigFile as Cf @@ -10,8 +10,9 @@ import Data.Either.Utils (forceEither) import Data.List (isPrefixOf) import Data.Maybe (fromJust) import Data.Version (showVersion) -import Database.MySQL.Base (ConnectInfo (..), defaultSSLInfo) -import Database.MySQL.Base.Types (Option (ReadDefaultFile, ReadDefaultGroup)) +import Database.MySQL.Base (ConnectInfo(..), defaultSSLInfo) +import Database.MySQL.Base.Types + (Option(ReadDefaultFile, ReadDefaultGroup)) import Paths_mywatch (getDataDir, version) import qualified System.Console.Docopt.NoTH as O import System.Environment (getArgs) @@ -23,8 +24,10 @@ usage :: IO String usage = do dataDir <- getDataDir return $ - "mywatch " ++ showVersion version - ++ " view queries on many MySQL servers" ++ [qc| + "mywatch " ++ + showVersion version ++ + " view queries on many MySQL servers" ++ + [qc| Usage: mywatch [options] MYCNF @@ -40,35 +43,38 @@ Options: |] -main :: IO() +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" - - cf <- forceEither <$> Cf.readfile Cf.emptyCP file - let - servers = filter ("client" /=) . Cf.sections $ cf - myInfo = map (\g -> ConnectInfo { - connectDatabase = "", - connectHost = "", - connectPassword = "", - connectPath = "", - connectPort = 0, + 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" + cf <- forceEither <$> Cf.readfile Cf.emptyCP file + let servers = filter ("client" /=) . Cf.sections $ cf + myInfo = + map + (\g -> + ConnectInfo + { connectDatabase = "" + , connectHost = "" + , connectPassword = "" + , connectPath = "" + , connectPort = 0 -- FIXME: https://jira.mariadb.org/browse/MDEV-10246 - connectSSL = if any (isPrefixOf "ssl") (forceEither $ Cf.options cf g) - then Just defaultSSLInfo else Nothing, - connectUser = "", + , connectSSL = + if any (isPrefixOf "ssl") (forceEither $ Cf.options cf g) + then Just defaultSSLInfo + else Nothing + , connectUser = "" -- FIXME: Work aroung buggy mysql: unsafeUseAsCString creates garbage. - connectOptions = [ ReadDefaultFile file, ReadDefaultGroup (pack $ g ++ "\0") ] - }) servers - listen = maybe (Right socket) (Left . read) port - server listen myInfo datadir - + , connectOptions = + [ReadDefaultFile file, ReadDefaultGroup (pack $ g ++ "\0")] + }) + servers + listen = maybe (Right socket) (Left . read) port + server listen myInfo datadir diff --git a/src/Server.hs b/src/Server.hs index 622b61b..45d2723 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -1,7 +1,6 @@ module Server -( - server -) where + ( server + ) where import Control.Exception.Base (bracket, catch, throwIO) import Data.Bits ((.|.)) @@ -12,60 +11,63 @@ 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 Database.MySQL.Base (ConnectInfo(connectOptions)) +import Database.MySQL.Base.Types (Option(ReadDefaultGroup)) import qualified Database.MySQL.Simple as MySQL -import Network.Socket (Family (AF_INET, AF_UNIX), - SockAddr (SockAddrInet, SockAddrUnix), Socket, - SocketOption (ReuseAddr), SocketType (Stream), bind, - close, getSocketName, inet_addr, listen, maxListenQueue, - setSocketOption, socket) -import Network.Wai.Handler.Warp (Port, defaultSettings, runSettingsSocket) +import Network.Socket + (Family(AF_INET, AF_UNIX), SockAddr(SockAddrInet, SockAddrUnix), + Socket, SocketOption(ReuseAddr), SocketType(Stream), bind, close, + getSocketName, inet_addr, listen, maxListenQueue, setSocketOption, + socket) +import Network.Wai.Handler.Warp + (Port, defaultSettings, runSettingsSocket) import System.IO (hPutStrLn, stderr) import System.IO.Error (isDoesNotExistError) -import System.Posix.Files (groupReadMode, groupWriteMode, ownerReadMode, - ownerWriteMode, removeLink, setFileMode, socketMode) +import System.Posix.Files + (groupReadMode, groupWriteMode, ownerReadMode, ownerWriteMode, + removeLink, setFileMode, socketMode) 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 ) + (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 = decodeUtf8 . getName . fromJust . find isGroup . connectOptions where isGroup (ReadDefaultGroup _) = True - isGroup _ = False + isGroup _ = False -- FIXME: Removing trailing zero added for buggy mysql in Main.hs. getName (ReadDefaultGroup n) = LBS.takeWhile (0 /=) . LBS.fromStrict $ n - getName _ = error "Cannot happen" - + 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 + setFileMode path $ + socketMode .|. ownerWriteMode .|. ownerReadMode .|. groupWriteMode .|. + groupReadMode hPutStrLn stderr $ "Listening on UNIX socket `" ++ path ++ "'" return sock createSocket (Left port) = do @@ -76,19 +78,17 @@ createSocket (Left port) = do 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 () - + _ -> return () removeIfExists :: FilePath -> IO () removeIfExists fileName = removeLink fileName `catch` handleExists - where handleExists e - | isDoesNotExistError e = return () - | otherwise = throwIO e - + where + handleExists e + | isDoesNotExistError e = return () + | otherwise = throwIO e |