aboutsummaryrefslogtreecommitdiff
path: root/src/Application.hs
diff options
context:
space:
mode:
authorIgor Pashev <pashev.igor@gmail.com>2016-06-13 15:48:13 +0800
committerIgor Pashev <pashev.igor@gmail.com>2016-06-14 04:02:31 +0800
commit76860ce667a40b69866241c1bf0b8ab76f50d1d2 (patch)
tree51b4ae1538bc0bf1effd0690081429ec508e010c /src/Application.hs
downloadmywatch-76860ce667a40b69866241c1bf0b8ab76f50d1d2.tar.gz
Version 0.1.00.1.0
Diffstat (limited to 'src/Application.hs')
-rw-r--r--src/Application.hs84
1 files changed, 84 insertions, 0 deletions
diff --git a/src/Application.hs b/src/Application.hs
new file mode 100644
index 0000000..63aa258
--- /dev/null
+++ b/src/Application.hs
@@ -0,0 +1,84 @@
+{-# 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 Data.List (sort)
+import Data.Pool (Pool, withResource)
+import Data.Text.Lazy (Text)
+import Database.MySQL.Simple (Connection, query_)
+import GHC.Generics (Generic)
+import Network.HTTP.Types (notFound404)
+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.IO (stderr)
+import Web.Scotty (ScottyM, ActionM, middleware, json, file, get,
+ status, text, param, scottyApp)
+import qualified Data.HashMap.Lazy as HM
+
+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
+ let
+ index_html = dataDir ++ "/" ++ "index.html"
+
+ middleware logger
+
+ middleware $ staticPolicy (hasPrefix "static" >-> addBase dataDir)
+ get "/" $ file index_html
+ get "/index.html" $ file index_html
+
+ get "/serverlist.json" $ json (sort $ HM.keys ps)
+ get "/server/:server/processlist.json" $ apiGetProcesses ps
+
+data Process = Process {
+ id :: Int
+ , user :: Text
+ , host :: Text
+ , db :: Maybe Text
+ , command :: Text
+ , time :: Int
+ , state :: Text
+ , info :: Text
+} deriving (Generic)
+instance ToJSON Process
+
+apiGetProcesses :: Pools -> ActionM ()
+apiGetProcesses 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)
+