Version 0.1.00.1.0

4 files changed, 284 insertions, 0 deletions

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
+