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
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
|
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Application (
app
) where
import Prelude hiding (id)
import Control.Monad.Trans (liftIO)
import Data.Aeson (ToJSON)
import Data.Default.Class (def)
import qualified Data.HashMap.Lazy as HM
import Data.List (sort)
import Data.Pool (Pool, withResource)
import Data.Text.Lazy (Text)
import Database.MySQL.Simple (Connection, Only (..), execute, query_)
import GHC.Generics (Generic)
import Network.HTTP.Types (StdMethod (HEAD), notFound404, notImplemented501,
ok200)
import Network.Wai (Application, Middleware)
import qualified Network.Wai.Middleware.Gzip as Gzip
import Network.Wai.Middleware.RequestLogger (Destination (Handle),
OutputFormat (CustomOutputFormat),
RequestLoggerSettings (destination, outputFormat),
mkRequestLogger)
import Network.Wai.Middleware.Static (addBase, hasPrefix, staticPolicy, (>->))
import System.FilePath.Posix ((</>))
import System.IO (stderr)
import Web.Scotty (ActionM, ScottyM, addroute, delete, file, get, json,
middleware, param, scottyApp, status, text)
import LogFormat (logFormat)
type Pools = HM.HashMap Text (Pool Connection)
app :: Pools -> FilePath -> IO Application
app ps f = do
logger <- mkRequestLogger def{ destination = Handle stderr
, outputFormat = CustomOutputFormat logFormat }
scottyApp (myProcess ps logger f)
myProcess :: Pools -> Middleware -> FilePath -> ScottyM ()
myProcess ps logger dataDir = do
middleware logger
middleware $ Gzip.gzip Gzip.def {Gzip.gzipFiles = Gzip.GzipCompress}
middleware $ staticPolicy (hasPrefix "static" >-> addBase dataDir)
get "/" $ file (dataDir </> "app.html")
get "/serverlist.json" $ json (sort $ HM.keys ps)
get "/server/:server/processlist.json" $ apiGetProcessList ps
-- Used by client to see which servers are really allowed by Sproxy
addroute HEAD "/server/:server/processlist.json" $ apiCanProcessList ps
delete "/server/:server/process/:id" $ apiKill ps
data Process = Process {
id :: Int
, user :: Text
, host :: Text
, db :: Maybe Text
, command :: Text
, time :: Int
, state :: Maybe Text
, info :: Text
} deriving (Generic)
instance ToJSON Process
apiCanProcessList :: Pools -> ActionM ()
apiCanProcessList ps = do
server <- param "server"
case HM.lookup server ps of
Nothing -> status notFound404 >> text server
Just _ -> status ok200
apiKill :: Pools -> ActionM ()
apiKill ps = do
server <- param "server"
case HM.lookup server ps of
Nothing -> status notFound404 >> text server
Just p -> do
id <- param "id"
if (id :: Int) == 0 then do
[ Only f ] <- withDB p $ \c ->
query_ c "SELECT COUNT(*) FROM information_schema.routines \
\WHERE routine_type = 'PROCEDURE' AND routine_schema = 'mysql' \
\AND routine_name = 'mywatch_kill'"
if (f::Int) > 0 then status ok200
else status notImplemented501 >> text "mywatch_kill"
else do
_ <- withDB p $ \c -> execute c "CALL mysql.mywatch_kill(?)" [ id ]
status ok200
apiGetProcessList :: Pools -> ActionM ()
apiGetProcessList ps = do
server <- param "server"
case HM.lookup server ps of
Nothing -> status notFound404 >> text server
Just p -> do
res <- withDB p $ \c ->
query_ c "SELECT \
\id, user, host, db, command, time, state, info \
\FROM information_schema.processlist \
\WHERE info IS NOT NULL \
\ORDER BY time DESC, id ASC"
json $ map (\(id, user, host, db, command, time, state, info) -> Process {..}) res
withDB :: Pool Connection -> (Connection -> IO a) -> ActionM a
withDB p a = liftIO $ withResource p (liftIO . a)
|
