{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Network.Legion.Admin (
runAdmin,
AdminMessage(..),
) where
import Canteven.HTTP (requestLogging, logExceptionsAndContinue)
import Control.Concurrent (forkIO, newChan, newEmptyMVar, writeChan,
putMVar, takeMVar, Chan)
import Control.Monad (void)
import Control.Monad.Logger (askLoggerIO, runLoggingT, logDebug)
import Control.Monad.Trans.Class (lift)
import Data.Conduit (Source)
import Data.Default.Class (def)
import Data.Text.Encoding (encodeUtf8)
import Data.Text.Lazy (Text, pack)
import Data.Version (showVersion)
import Network.HTTP.Types (notFound404)
import Network.Legion.Application (LegionConstraints)
import Network.Legion.Conduit (chanToSource)
import Network.Legion.Distribution (Peer)
import Network.Legion.LIO (LIO)
import Network.Legion.PartitionKey (PartitionKey(K))
import Network.Legion.PartitionState (PartitionPowerState)
import Network.Legion.StateMachine (NodeState)
import Network.Wai (Middleware, modifyResponse)
import Network.Wai.Handler.Warp (HostPreference, defaultSettings, Port,
setHost, setPort)
import Network.Wai.Middleware.AddHeaders (addHeaders)
import Network.Wai.Middleware.StripHeaders (stripHeader)
import Paths_legion (version)
import Text.Read (readMaybe)
import Web.Scotty.Resource.Trans (resource, get, delete)
import Web.Scotty.Trans (Options, scottyOptsT, settings, ScottyT, text,
ActionT, param, middleware, status)
import qualified Data.Text as T
runAdmin :: (LegionConstraints e o s)
=> Port
-> HostPreference
-> LIO (Source LIO (AdminMessage e o s))
runAdmin addr host = do
logging <- askLoggerIO
chan <- lift newChan
void . lift . forkIO . (`runLoggingT` logging) $
let
website :: ScottyT Text LIO ()
website = do
middleware
$ requestLogging logging
. setServer
. logExceptionsAndContinue logging
resource "/clusterstate" $
get $ do
val <- send chan GetState
text (pack (show val))
resource "/propstate/:key" $
get $ do
key <- K . read <$> param "key"
val <- send chan (GetPart key)
text (pack (show val))
resource "/peers/:peer" $
delete $
readMaybe <$> param "peer" >>= \case
Nothing -> status notFound404
Just peer -> do
lift . $(logDebug) . T.pack $ "Ejecting peer: " ++ show peer
send chan (Eject peer)
in scottyOptsT (options addr host) (`runLoggingT` logging) website
return (chanToSource chan)
where
send
:: Chan (AdminMessage e o s)
-> ((a -> LIO ()) -> AdminMessage e o s)
-> ActionT Text LIO a
send chan msg = lift . lift $ do
mvar <- newEmptyMVar
writeChan chan (msg (lift . putMVar mvar))
takeMVar mvar
options :: Port -> HostPreference -> Options
options port host = def {
settings =
setPort port
. setHost host
$ defaultSettings
}
setServer :: Middleware
setServer = addServerHeader . stripServerHeader
where
stripServerHeader :: Middleware
stripServerHeader = modifyResponse (stripHeader "Server")
addServerHeader :: Middleware
addServerHeader = addHeaders [("Server", serverValue)]
serverValue =
encodeUtf8 (T.pack ("legion-admin/" ++ showVersion version))
data AdminMessage e o s
= GetState (NodeState e o s -> LIO ())
| GetPart PartitionKey (Maybe (PartitionPowerState e o s) -> LIO ())
| Eject Peer (() -> LIO ())
instance Show (AdminMessage e o s) where
show (GetState _) = "(GetState _)"
show (GetPart k _) = "(GetPart " ++ show k ++ " _)"
show (Eject p _) = "(Eject " ++ show p ++ " _)"