From 65b71a99fdb60ad063cb7e8976143027b1e260e7 Mon Sep 17 00:00:00 2001 From: Igor Pashev Date: Thu, 3 Aug 2017 21:03:32 +0300 Subject: hindent wins --- .hindent.yaml | 3 + .stylish-haskell.yaml | 189 -------------------------------------------------- src/Application.hs | 108 ++++++++++++++++------------- src/LogFormat.hs | 58 ++++++++-------- src/Main.hs | 72 ++++++++++--------- src/Server.hs | 80 ++++++++++----------- 6 files changed, 170 insertions(+), 340 deletions(-) create mode 100644 .hindent.yaml delete mode 100644 .stylish-haskell.yaml diff --git a/.hindent.yaml b/.hindent.yaml new file mode 100644 index 0000000..3dba089 --- /dev/null +++ b/.hindent.yaml @@ -0,0 +1,3 @@ +indent-size: 2 +line-length: 80 +force-trailing-newline: true diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml deleted file mode 100644 index de87c17..0000000 --- a/.stylish-haskell.yaml +++ /dev/null @@ -1,189 +0,0 @@ -# stylish-haskell configuration file -# ================================== - -# The stylish-haskell tool is mainly configured by specifying steps. These steps -# are a list, so they have an order, and one specific step may appear more than -# once (if needed). Each file is processed by these steps in the given order. -steps: - # Convert some ASCII sequences to their Unicode equivalents. This is disabled - # by default. - # - unicode_syntax: - # # In order to make this work, we also need to insert the UnicodeSyntax - # # language pragma. If this flag is set to true, we insert it when it's - # # not already present. You may want to disable it if you configure - # # language extensions using some other method than pragmas. Default: - # # true. - # add_language_pragma: true - - # Align the right hand side of some elements. This is quite conservative - # and only applies to statements where each element occupies a single - # line. - - simple_align: - cases: true - top_level_patterns: true - records: true - - # Import cleanup - - imports: - # There are different ways we can align names and lists. - # - # - global: Align the import names and import list throughout the entire - # file. - # - # - file: Like global, but don't add padding when there are no qualified - # imports in the file. - # - # - group: Only align the imports per group (a group is formed by adjacent - # import lines). - # - # - none: Do not perform any alignment. - # - # Default: global. - align: none - - # Folowing options affect only import list alignment. - # - # List align has following options: - # - # - after_alias: Import list is aligned with end of import including - # 'as' and 'hiding' keywords. - # - # > import qualified Data.List as List (concat, foldl, foldr, head, - # > init, last, length) - # - # - with_alias: Import list is aligned with start of alias or hiding. - # - # > import qualified Data.List as List (concat, foldl, foldr, head, - # > init, last, length) - # - # - new_line: Import list starts always on new line. - # - # > import qualified Data.List as List - # > (concat, foldl, foldr, head, init, last, length) - # - # Default: after_alias - list_align: after_alias - - # Long list align style takes effect when import is too long. This is - # determined by 'columns' setting. - # - # - inline: This option will put as much specs on same line as possible. - # - # - new_line: Import list will start on new line. - # - # - new_line_multiline: Import list will start on new line when it's - # short enough to fit to single line. Otherwise it'll be multiline. - # - # - multiline: One line per import list entry. - # Type with contructor list acts like single import. - # - # > import qualified Data.Map as M - # > ( empty - # > , singleton - # > , ... - # > , delete - # > ) - # - # Default: inline - long_list_align: inline - - # Align empty list (importing instances) - # - # Empty list align has following options - # - # - inherit: inherit list_align setting - # - # - right_after: () is right after the module name: - # - # > import Vector.Instances () - # - # Default: inherit - empty_list_align: inherit - - # List padding determines indentation of import list on lines after import. - # This option affects 'long_list_align'. - # - # - : constant value - # - # - module_name: align under start of module name. - # Useful for 'file' and 'group' align settings. - list_padding: 4 - - # Separate lists option affects formating of import list for type - # or class. The only difference is single space between type and list - # of constructors, selectors and class functions. - # - # - true: There is single space between Foldable type and list of it's - # functions. - # - # > import Data.Foldable (Foldable (fold, foldl, foldMap)) - # - # - false: There is no space between Foldable type and list of it's - # functions. - # - # > import Data.Foldable (Foldable(fold, foldl, foldMap)) - # - # Default: true - separate_lists: true - - # Language pragmas - - language_pragmas: - # We can generate different styles of language pragma lists. - # - # - vertical: Vertical-spaced language pragmas, one per line. - # - # - compact: A more compact style. - # - # - compact_line: Similar to compact, but wrap each line with - # `{-#LANGUAGE #-}'. - # - # Default: vertical. - style: vertical - - # Align affects alignment of closing pragma brackets. - # - # - true: Brackets are aligned in same collumn. - # - # - false: Brackets are not aligned together. There is only one space - # between actual import and closing bracket. - # - # Default: true - align: true - - # stylish-haskell can detect redundancy of some language pragmas. If this - # is set to true, it will remove those redundant pragmas. Default: true. - remove_redundant: true - - # Replace tabs by spaces. This is disabled by default. - # - tabs: - # # Number of spaces to use for each tab. Default: 8, as specified by the - # # Haskell report. - # spaces: 8 - - # Remove trailing whitespace - - trailing_whitespace: {} - -# A common setting is the number of columns (parts of) code will be wrapped -# to. Different steps take this into account. Default: 80. -columns: 80 - -# By default, line endings are converted according to the OS. You can override -# preferred format here. -# -# - native: Native newline format. CRLF on Windows, LF on other OSes. -# -# - lf: Convert to LF ("\n"). -# -# - crlf: Convert to CRLF ("\r\n"). -# -# Default: native. -newline: lf - -# Sometimes, language extensions are specified in a cabal file or from the -# command line instead of using language pragmas in the file. stylish-haskell -# needs to be aware of these, so it can parse the file correctly. -# -# No language extensions are enabled by default. -# language_extensions: - # - TemplateHaskell - # - QuasiQuotes 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 -- cgit v1.2.3