diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Main.hs | 158 | ||||
| -rw-r--r-- | src/Server.hs | 98 |
2 files changed, 156 insertions, 100 deletions
diff --git a/src/Main.hs b/src/Main.hs index 7e72a0a..45a6a0a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,73 +1,113 @@ -{-# LANGUAGE QuasiQuotes #-} - -module Main ( - main -) where +module Main + ( main + ) where import Data.ByteString.Char8 (pack) -import Data.Maybe (fromJust) import Data.Version (showVersion) import Database.MySQL.Base (ConnectInfo(..)) import Database.MySQL.Base.Types (Option(ReadDefaultFile, ReadDefaultGroup)) import Paths_juandelacosa (getDataDir, version) -- from cabal -import System.Environment (getArgs) -import Text.InterpolatedString.Perl6 (qc) -import qualified System.Console.Docopt.NoTH as O - -import Server (server) - -usage :: IO String -usage = do - dataDir <- getDataDir - return $ - "juandelacosa " ++ showVersion version - ++ " manage MariaDB user and roles" ++ [qc| +import System.IO.Unsafe (unsafePerformIO) -Usage: - juandelacosa [options] +import Options.Applicative + ( Parser + , (<**>) + , (<|>) + , auto + , execParser + , fullDesc + , header + , help + , helper + , info + , long + , metavar + , option + , optional + , short + , showDefault + , strOption + , value + ) -Options: - -f, --file=MYCNF Read this MySQL client config file - -g, --group=GROUP Read this options group in the above file [default: client] +import Server (Listen(Port, Socket), server) - -d, --datadir=DIR Data directory including static files [default: {dataDir}] +data Config = + Config + { file :: Maybe FilePath + , group :: String + , datadir :: FilePath + , listen :: Listen + } - -s, --socket=SOCK Listen on this UNIX-socket [default: /tmp/juandelacosa.sock] - -p, --port=PORT Instead of UNIX-socket, listen on this TCP port (localhost) +parseListen :: Parser Listen +parseListen = port <|> socket + where + port = + Port <$> + option + auto + (long "port" <> + short 'p' <> + metavar "INT" <> help "listen on this TCP port (localhost only)") + socket = + Socket <$> + option + auto + (long "socket" <> + short 's' <> + metavar "PATH" <> + value "/tmp/juandelacosa.sock" <> + showDefault <> help "Listen on this UNIX-socket") - -h, --help Show this message +{-# NOINLINE dataDir #-} +dataDir :: FilePath +dataDir = unsafePerformIO getDataDir -|] +parseConfig :: Parser Config +parseConfig = + Config <$> + optional + (strOption + (long "file" <> + short 'f' <> metavar "FILE" <> help "Read this MySQL client config file")) <*> + strOption + (long "group" <> + short 'g' <> + metavar "STRING" <> + value "client" <> + showDefault <> help "Read this options group in the above file") <*> + strOption + (long "datadir" <> + short 'd' <> + metavar "DIR" <> + value dataDir <> + showDefault <> help "Data directory including static files") <*> + parseListen -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 = O.getArg args $ O.longOption "file" - group = fromJust $ O.getArg args $ O.longOption "group" - port = O.getArg args $ O.longOption "port" - socket = fromJust $ O.getArg args $ O.longOption "socket" - datadir = fromJust $ O.getArg args $ O.longOption "datadir" - -- XXX: mysql package maps empty strings to NULL - -- which is what we need, see documentation for mysql_real_connect() - let myInfo = ConnectInfo { - connectDatabase = "", - connectHost = "", - connectOptions = case file of - Nothing -> [] - Just f -> [ ReadDefaultFile f, ReadDefaultGroup (pack group) ], - connectPassword = "", - connectPath = "", - connectPort = 0, - connectSSL = Nothing, - connectUser = "" - } - let listen = case port of - Nothing -> Right socket - Just p -> Left $ read p - server listen myInfo datadir +run :: Config -> IO () +run cfg = do + let myInfo = + ConnectInfo + { connectDatabase = "" + , connectHost = "" + , connectOptions = + case file cfg of + Nothing -> [] + Just f -> + [ReadDefaultFile f, ReadDefaultGroup (pack $ group cfg)] + , connectPassword = "" + , connectPath = "" + , connectPort = 0 + , connectSSL = Nothing + , connectUser = "" + } + server (listen cfg) myInfo (datadir cfg) +main :: IO () +main = run =<< execParser opts + where + opts = info (parseConfig <**> helper) (fullDesc <> header desc) + desc = + "juandelacosa " ++ + showVersion version ++ " - manage MariaDB user and roles" diff --git a/src/Server.hs b/src/Server.hs index 10d4328..14d7579 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -1,60 +1,78 @@ module Server -( - server -) where + ( Listen(..) + , server + ) where -import Control.Exception.Base (throwIO, catch, bracket) +import Control.Exception.Base (bracket, catch, throwIO) import Data.Bits ((.|.)) import Data.Pool (createPool, destroyAllResources) import Database.MySQL.Base (ConnectInfo) -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 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 System.IO (hPutStrLn, stderr) import System.IO.Error (isDoesNotExistError) -import System.Posix.Files (removeLink, setFileMode, socketMode, ownerReadMode, - ownerWriteMode, groupReadMode, groupWriteMode) -import qualified Database.MySQL.Simple as MySQL +import System.Posix.Files + ( groupReadMode + , groupWriteMode + , ownerReadMode + , ownerWriteMode + , removeLink + , setFileMode + , socketMode + ) import Application (app) -type Listen = Either Port FilePath - +data Listen + = Socket FilePath + | Port Int server :: Listen -> ConnectInfo -> FilePath -> IO () server socketSpec mysqlConnInfo dataDir = bracket - ( do - sock <- createSocket socketSpec - mysql <- createPool - (MySQL.connect mysqlConnInfo) - MySQL.close - 1 -- stripes - 60 -- keep alive (seconds) - 10 -- max connections - return (sock, mysql) ) - ( \(sock, mysql) -> do - closeSocket sock - destroyAllResources mysql ) - ( \(sock, mysql) -> do - listen sock maxListenQueue - hPutStrLn stderr $ "Static files from `" ++ dataDir ++ "'" - runSettingsSocket defaultSettings sock =<< app mysql dataDir) - + (do sock <- createSocket socketSpec + mysql <- + createPool + (MySQL.connect mysqlConnInfo) + MySQL.close + 1 -- stripes + 60 -- keep alive (seconds) + 10 -- max connections + return (sock, mysql)) + (\(sock, mysql) -> do + closeSocket sock + destroyAllResources mysql) + (\(sock, mysql) -> do + listen sock maxListenQueue + hPutStrLn stderr $ "Static files from `" ++ dataDir ++ "'" + runSettingsSocket defaultSettings sock =<< app mysql dataDir) createSocket :: Listen -> IO Socket -createSocket (Right path) = do +createSocket (Socket 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 +createSocket (Port port) = do sock <- socket AF_INET Stream 0 setSocketOption sock ReuseAddr 1 addr <- inet_addr "127.0.0.1" @@ -62,7 +80,6 @@ createSocket (Left port) = do hPutStrLn stderr $ "Listening on localhost:" ++ show port return sock - closeSocket :: Socket -> IO () closeSocket sock = do name <- getSocketName sock @@ -71,10 +88,9 @@ closeSocket sock = do SockAddrUnix path -> removeIfExists path _ -> 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 |