1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
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 Data.Text.Lazy (Text, toLower)
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(CustomOutputFormat))
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 LogFormat (logFormat)
app :: Pool Connection -> FilePath -> IO Application
app p f = do
logger <- mkRequestLogger def{ destination = Handle stderr
, outputFormat = CustomOutputFormat logFormat }
scottyApp (juanDeLaCosa p logger f)
juanDeLaCosa :: Pool Connection -> Middleware -> FilePath -> ScottyM ()
juanDeLaCosa p logger dataDir = do
middleware logger
middleware $ staticPolicy (hasPrefix "static" >-> addBase dataDir)
get "/" $ file (dataDir ++ "/" ++ "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 email -> do
let login = emailToLogin email
[ 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 email -> do
let login = emailToLogin email
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)
emailToLogin :: Text -> Text
emailToLogin = toLower
|
