Version 0.0.1

3 files changed, 197 insertions, 0 deletions

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
+