diff options
Diffstat (limited to 'src/Application.hs')
| -rw-r--r-- | src/Application.hs | 108 |
1 files changed, 59 insertions, 49 deletions
diff --git a/src/Application.hs b/src/Application.hs index 0b7ca52..5624aec 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -module Application ( - app -) where +module Application + ( app + ) where import Prelude hiding (id) @@ -17,21 +17,23 @@ 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 Database.MySQL.Simple + (Connection, Only(..), execute, query_) import GHC.Generics (Generic) -import Network.HTTP.Types (StdMethod (HEAD), notFound404, notImplemented501, - ok200) +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 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 Web.Scotty + (ActionM, ScottyM, addroute, delete, file, get, json, middleware, + param, scottyApp, status, text) import LogFormat (logFormat) @@ -39,37 +41,35 @@ 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 } + logger <- + mkRequestLogger + def + {destination = Handle stderr, outputFormat = CustomOutputFormat logFormat} scottyApp (myProcess ps logger f) -myProcess :: Pools -> Middleware -> FilePath -> ScottyM () +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 +data Process = Process + { id :: Int + , user :: Text + , host :: Text + , db :: Maybe Text , command :: Text - , time :: Int - , state :: Maybe Text - , info :: Text -} deriving (Generic) + , time :: Int + , state :: Maybe Text + , info :: Text + } deriving (Generic) + instance ToJSON Process apiCanProcessList :: Pools -> ActionM () @@ -77,40 +77,50 @@ apiCanProcessList ps = do server <- param "server" case HM.lookup server ps of Nothing -> status notFound404 >> text server - Just _ -> status ok200 + 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 + 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 \ + 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 + 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 \ + 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 + 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) - |