aboutsummaryrefslogtreecommitdiff
path: root/src/Application.hs
diff options
context:
space:
mode:
authorIgor Pashev <pashev.igor@gmail.com>2016-04-06 03:16:36 +0800
committerIgor Pashev <pashev.igor@gmail.com>2016-04-06 15:56:28 +0800
commitcd428a60b178aa621ac26e47a7d404af596eecd1 (patch)
treeb13f55dfbf6682d4c380013f75dcb8a482ba93c6 /src/Application.hs
downloadjuandelacosa-cd428a60b178aa621ac26e47a7d404af596eecd1.tar.gz
Version 0.0.1
Diffstat (limited to 'src/Application.hs')
-rw-r--r--src/Application.hs52
1 files changed, 52 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
+