From 8a02852030716dbdbd64efdd4954ab9ac8f828f9 Mon Sep 17 00:00:00 2001 From: Igor Pashev Date: Wed, 8 Jun 2016 05:00:16 +0800 Subject: Simple Web UI for changing password Using Bootstrap & jQuery. --- src/Application.hs | 95 +++++++++++++++++++++++++++++++++--------------------- src/Main.hs | 20 ++++++++---- src/Server.hs | 7 ++-- 3 files changed, 75 insertions(+), 47 deletions(-) (limited to 'src') diff --git a/src/Application.hs b/src/Application.hs index 0ac37cf..b3d7fb1 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -1,52 +1,73 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} -module Application -( +module Application ( app ) where +import Control.Monad.Trans (liftIO) import Data.ByteString.Base64 (encode) +import Data.Default.Class (def) 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 Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8) +import Database.MySQL.Simple (Connection, Only(..), query, execute) +import Network.HTTP.Types (notFound404, badRequest400) +import Network.Wai (Application, Middleware) +import Network.Wai.Middleware.RequestLogger (Destination(Handle), + mkRequestLogger, RequestLoggerSettings(destination, outputFormat), + OutputFormat(Apache), IPAddrSource(FromHeader)) +import Network.Wai.Middleware.Static (addBase, hasPrefix, staticPolicy, (>->)) import System.Entropy (getEntropy) import System.IO (stderr) +import Web.Scotty (ScottyM, ActionM, header, middleware, file, get, post, + status, text, scottyApp) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS -import qualified Data.CaseInsensitive as CI +app :: Pool Connection -> FilePath -> IO Application +app p f = do + logger <- mkRequestLogger def{ destination = Handle stderr, outputFormat = Apache FromHeader } + scottyApp (juanDeLaCosa p logger f) -app :: Pool Connection -> Application -app p request respond = do +juanDeLaCosa :: Pool Connection -> Middleware -> FilePath -> ScottyM () +juanDeLaCosa p logger dataDir = 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 + index_html = dataDir ++ "/" ++ "index.html" + + middleware logger + + middleware $ staticPolicy (hasPrefix "static" >-> addBase dataDir) + get "/" $ file index_html + get "/index.html" $ file index_html + + post "/resetMyPassword" $ apiResetMyPassword p + get "/whoAmI" $ apiWhoAmI p + + +apiWhoAmI :: Pool Connection -> ActionM () +apiWhoAmI p = + header "From" >>= \case + Nothing -> status badRequest400 >> text "Missing header `From'" + Just login -> do + [ Only n ] <- withDB p $ \c -> + query c "SELECT COUNT(*) FROM mysql.user WHERE User=? AND Host='%'" + [ LBS.toStrict . encodeUtf8 $ login ] + if (n::Int) > 0 + then text login + else status notFound404 >> text login + +apiResetMyPassword :: Pool Connection -> ActionM () +apiResetMyPassword p = + header "From" >>= \case + Nothing -> status badRequest400 >> text "Missing header `From'" + Just login -> do + password <- liftIO $ BS.takeWhile (/= '=') . encode <$> getEntropy 13 + _ <- withDB p $ \c -> execute c "SET PASSWORD FOR ?@'%' = PASSWORD(?)" + [ LBS.toStrict . encodeUtf8 $ login, password ] + text . decodeUtf8 . LBS.fromStrict $ password + + +withDB :: Pool Connection -> (Connection -> IO a) -> ActionM a +withDB p a = liftIO $ withResource p (liftIO . a) diff --git a/src/Main.hs b/src/Main.hs index 58ae99f..7e72a0a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -9,16 +9,19 @@ 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 Paths_juandelacosa (getDataDir, version) -- from cabal import System.Environment (getArgs) -import Text.RawString.QQ (r) +import Text.InterpolatedString.Perl6 (qc) import qualified System.Console.Docopt.NoTH as O import Server (server) -usage :: String -usage = "juandelacosa " ++ showVersion version - ++ " manage MariaDB user and roles" ++ [r| +usage :: IO String +usage = do + dataDir <- getDataDir + return $ + "juandelacosa " ++ showVersion version + ++ " manage MariaDB user and roles" ++ [qc| Usage: juandelacosa [options] @@ -27,6 +30,8 @@ Options: -f, --file=MYCNF Read this MySQL client config file -g, --group=GROUP Read this options group in the above file [default: client] + -d, --datadir=DIR Data directory including static files [default: {dataDir}] + -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) @@ -36,7 +41,7 @@ Options: main :: IO() main = do - doco <- O.parseUsageOrExit usage + doco <- O.parseUsageOrExit =<< usage args <- O.parseArgsOrExit doco =<< getArgs if args `O.isPresent` O.longOption "help" then putStrLn $ O.usage doco @@ -46,6 +51,7 @@ main = do 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 { @@ -63,5 +69,5 @@ main = do let listen = case port of Nothing -> Right socket Just p -> Left $ read p - server listen myInfo + server listen myInfo datadir diff --git a/src/Server.hs b/src/Server.hs index ee9aad2..10d4328 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -23,8 +23,8 @@ import Application (app) type Listen = Either Port FilePath -server :: Listen -> ConnectInfo -> IO () -server socketSpec mysqlConnInfo = +server :: Listen -> ConnectInfo -> FilePath -> IO () +server socketSpec mysqlConnInfo dataDir = bracket ( do sock <- createSocket socketSpec @@ -40,7 +40,8 @@ server socketSpec mysqlConnInfo = destroyAllResources mysql ) ( \(sock, mysql) -> do listen sock maxListenQueue - runSettingsSocket defaultSettings sock (app mysql) ) + hPutStrLn stderr $ "Static files from `" ++ dataDir ++ "'" + runSettingsSocket defaultSettings sock =<< app mysql dataDir) createSocket :: Listen -> IO Socket -- cgit v1.2.3