aboutsummaryrefslogtreecommitdiff
path: root/src/Application.hs
diff options
context:
space:
mode:
authorIgor Pashev <pashev.igor@gmail.com>2016-06-08 05:00:16 +0800
committerIgor Pashev <pashev.igor@gmail.com>2016-06-08 23:42:31 +0800
commit8a02852030716dbdbd64efdd4954ab9ac8f828f9 (patch)
tree690a216e08f4a2d97dfe80886fd2053f4283c4b0 /src/Application.hs
parent50fbf638a92b0dfc85b9000bc026911f798dede8 (diff)
downloadjuandelacosa-8a02852030716dbdbd64efdd4954ab9ac8f828f9.tar.gz
Simple Web UI for changing password
Using Bootstrap & jQuery.
Diffstat (limited to 'src/Application.hs')
-rw-r--r--src/Application.hs95
1 files changed, 58 insertions, 37 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)