aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Main.hs158
-rw-r--r--src/Server.hs98
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