Simple Web UI for changing password

Using Bootstrap & jQuery.

3 files changed, 75 insertions, 47 deletions

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