From cd428a60b178aa621ac26e47a7d404af596eecd1 Mon Sep 17 00:00:00 2001 From: Igor Pashev Date: Wed, 6 Apr 2016 03:16:36 +0800 Subject: Version 0.0.1 --- src/Application.hs | 52 ++++++++++++++++++++++++++++++++++++ src/Main.hs | 67 ++++++++++++++++++++++++++++++++++++++++++++++ src/Server.hs | 78 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 197 insertions(+) create mode 100644 src/Application.hs create mode 100644 src/Main.hs create mode 100644 src/Server.hs (limited to 'src') diff --git a/src/Application.hs b/src/Application.hs new file mode 100644 index 0000000..0ac37cf --- /dev/null +++ b/src/Application.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Application +( + app +) where + +import Data.ByteString.Base64 (encode) +import Data.Pool (Pool, withResource) +import Database.MySQL.Simple (Connection, execute) +import Network.HTTP.Types (status200, badRequest400, Header) +import Network.HTTP.Types.Header (hContentType) +import Network.Wai (Application, requestHeaders, responseLBS, Response) +import System.Entropy (getEntropy) +import System.IO (stderr) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.CaseInsensitive as CI + + +app :: Pool Connection -> Application +app p request respond = do + let + headers = requestHeaders request + from = readHeader "From" headers + case from of + Just login -> apiResetPassword p login >>= respond + Nothing -> respond $ responseLBS + badRequest400 + [(hContentType, "text/plain")] + "Missing the From header" + + +apiResetPassword :: Pool Connection -> BS.ByteString -> IO Response +apiResetPassword p login = withResource p $ + \c -> do + blab ["SET PASSWORD FOR '", login, "'@'%'"] + password <- BS.takeWhile (/= '=') . encode <$> getEntropy 12 + _ <- execute c "SET PASSWORD FOR ?@'%' = PASSWORD(?)" [ login, password ] + return $ responseLBS + status200 + [(hContentType, "text/plain")] + (LBS.fromStrict password) + + +readHeader :: BS.ByteString -> [Header] -> Maybe BS.ByteString +readHeader h = lookup (CI.mk h) + + +blab :: [BS.ByteString] -> IO () +blab = BS.hPutStrLn stderr . BS.concat + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..58ae99f --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE QuasiQuotes #-} + +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 (version) -- from cabal +import System.Environment (getArgs) +import Text.RawString.QQ (r) +import qualified System.Console.Docopt.NoTH as O + +import Server (server) + +usage :: String +usage = "juandelacosa " ++ showVersion version + ++ " manage MariaDB user and roles" ++ [r| + +Usage: + juandelacosa [options] + +Options: + -f, --file=MYCNF Read this MySQL client config file + -g, --group=GROUP Read this options group in the above file [default: client] + + -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) + + -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 = 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" + -- 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 + diff --git a/src/Server.hs b/src/Server.hs new file mode 100644 index 0000000..3ecb642 --- /dev/null +++ b/src/Server.hs @@ -0,0 +1,78 @@ +module Server +( + server +) where + +import Control.Exception.Base (throwIO, catch, bracket) +import Data.Bits ((.|.)) +import Data.Pool (createPool, destroyAllResources) +import Database.MySQL.Base (ConnectInfo) +import Network.Socket (socket, bind, listen, close, maxListenQueue, + getSocketName, inet_addr, + Family(AF_UNIX, AF_INET), SocketType(Stream), + 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 Database.MySQL.Simple as MySQL + +import Application (app) + +type Listen = Either Port FilePath + + +server :: Listen -> ConnectInfo -> IO () +server socketSpec mysqlConnInfo = + 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 + runSettingsSocket defaultSettings sock (app mysql) ) + + +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 + 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 + -- cgit v1.2.3