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
|
{-# 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.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
let
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)
|
