aboutsummaryrefslogtreecommitdiff
path: root/src/Application.hs
blob: d2e7f6bf430f68dedbb521ee9c6d522930bc21da (plain)
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
{-# 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 (ok200, notFound404, StdMethod(HEAD))
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, addroute, 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" $ apiGetProcessList ps

  -- Used by client to see which servers are really allowed by Sproxy
  addroute HEAD "/server/:server/processlist.json" $ apiCanProcessList 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

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)