module Web.Moonshine (
Moonshine,
runMoonshine,
route,
makeTimer,
timerAdd,
Timer,
timed,
liftSnap,
liftIO,
setBanner,
timedIO,
makeGauge,
gaugeInc,
gaugeDec,
gaugeSet,
gaugeAdd,
gaugeSubtract,
Gauge,
) where
import Canteven.Config (canteven)
import Control.Applicative (Applicative(pure, (<*>)), (<|>))
import Control.Monad (ap, liftM)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Data.Aeson (Value(Object), (.:?), (.!=), (.!=))
import Data.ByteString (ByteString)
import Data.Int (Int64)
import Data.Maybe (fromMaybe)
import Data.Monoid (mempty, mconcat)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Data.Time.Clock (getCurrentTime, diffUTCTime)
import Data.Yaml (FromJSON(parseJSON))
import GHC.Generics (Generic)
import Snap (Snap, httpServe, setPort, Config, setSSLCert, setSSLKey,
setSSLPort, setResponseCode, getResponse, finishWith, setAccessLog,
setErrorLog, ConfigLog(ConfigIoLog))
import System.Environment (setEnv, lookupEnv)
import System.Log.Logger (infoM, errorM)
import System.Metrics (registerGcMetrics)
import System.Metrics.Distribution (Distribution)
import System.Remote.Monitoring (Server, forkServerWith)
import qualified Data.Text as T (unpack)
import qualified Snap (route)
import qualified System.Log.Logger as L (debugM)
import qualified System.Metrics as EkgMetrics
import qualified System.Metrics.Distribution as D (add)
import qualified System.Metrics.Gauge as G (inc, Gauge, dec, set, add, subtract)
data Moonshine a =
Moonshine (State -> IO (State , a))
instance Monad Moonshine where
return a = Moonshine (\state -> return (state, a))
(Moonshine m) >>= fun = Moonshine $ \state -> do
(newState, val) <- m state
let Moonshine m2 = fun val
m2 newState
instance Applicative Moonshine where
pure = return
(<*>) = ap
instance Functor Moonshine where
fmap = liftM
instance MonadIO Moonshine where
liftIO io = Moonshine (\state -> do
val <- io
return (state, val)
)
newtype Timer = T Distribution
newtype Gauge = G {unGauge :: G.Gauge}
data ServerConfig =
ServerConfig {
applicationConnector :: [ConnectorConfig],
adminConnector :: [ConnectorConfig]
} deriving (Generic)
instance FromJSON ServerConfig
data ConnectorConfig = ConnectorConfig {
scheme :: Scheme
, port :: Int
, cert :: Maybe FilePath
, key :: Maybe FilePath
} deriving (Generic)
instance FromJSON ConnectorConfig
data Scheme = HTTP | HTTPS
deriving (Generic)
instance FromJSON Scheme
runMoonshine :: Moonshine a -> IO a
runMoonshine (Moonshine m) = do
printBanner
MoonshineConfig {mcServerConfig} <- canteven
metricsStore <- EkgMetrics.newStore
(State {snap}, val) <- m State {
snap = return (),
metricsStore
}
let snap2 = snap <|> notFound
startServer mcServerConfig metricsStore snap2
return val
where
notFound :: Snap a
notFound = do
response <- fmap (setResponseCode 404) getResponse
finishWith response
data MoonshineConfig =
MoonshineConfig {
mcServerConfig :: ServerConfig
}
instance FromJSON MoonshineConfig where
parseJSON v =
case v of
Object topLevel -> do
mcServerConfig <- topLevel .:? "server" .!= defaultServerConfig
return MoonshineConfig {mcServerConfig}
_ ->
fail $ "Couldn't parse system config from value: " ++ show v
route :: [(ByteString, Moonshine ())] -> Moonshine ()
route routes = Moonshine $ \state@State {snap, metricsStore} -> do
snapRoutes <- mapM (getUnboundSnapRoute state) routes
monitoredRoutes <- mapM (monitorRoute metricsStore) snapRoutes
return (state {snap = snap >> Snap.route monitoredRoutes}, ())
where
getUnboundSnapRoute state (path, Moonshine m) = do
(State {snap}, ()) <- m state {snap = return ()}
return (path, snap)
monitorRoute
:: EkgMetrics.Store
-> (ByteString, Snap ())
-> IO (ByteString, Snap ())
monitorRoute metricsStore (path, snap) = do
timer <- getDistribution (decodeUtf8 path) metricsStore
return (path, timedSnap timer snap)
liftSnap :: Snap () -> Moonshine ()
liftSnap s = Moonshine (\state@State {snap} ->
return (state {snap = snap >> s}, ())
)
timed
:: Text
-> Moonshine a
-> Moonshine a
timed name (Moonshine m) = Moonshine $ \state@State {snap, metricsStore} -> do
timer <- getDistribution name metricsStore
m state {snap = timedSnap timer snap}
makeTimer :: Text -> Moonshine Timer
makeTimer name = Moonshine (\state@State {metricsStore} -> do
dist <- getDistribution name metricsStore
return (state, T dist)
)
timerAdd :: (Real time, MonadIO io) => Timer -> time -> io ()
timerAdd (T timer) = liftIO . D.add timer . fromRational . toRational
timedIO :: (MonadIO io) => Timer -> io a -> io a
timedIO timer io = do
start <- liftIO getCurrentTime
result <- io
end <- liftIO getCurrentTime
timerAdd timer (diffUTCTime end start)
return result
setBanner :: String -> IO ()
setBanner = setEnv bannerEnvName
gaugeInc :: (MonadIO io) => Gauge -> io ()
gaugeInc = liftIO . G.inc . unGauge
gaugeDec :: (MonadIO io) => Gauge -> io ()
gaugeDec = liftIO . G.dec . unGauge
gaugeSet :: (MonadIO io) => Gauge -> Int64 -> io ()
gaugeSet (G gauge) = liftIO . G.set gauge
gaugeSubtract :: (MonadIO io) => Gauge -> Int64 -> io ()
gaugeSubtract (G gauge) = liftIO . G.subtract gauge
gaugeAdd :: (MonadIO io) => Gauge -> Int64 -> io ()
gaugeAdd (G gauge) = liftIO . G.add gauge
makeGauge :: Text -> Moonshine Gauge
makeGauge name = Moonshine (\state@State {metricsStore} -> do
gauge <- EkgMetrics.createGauge name metricsStore
return (state, G gauge)
)
data Opt = Help
| Config String
deriving Show
data State =
State {
snap :: Snap (),
metricsStore :: EkgMetrics.Store
}
defaultServerConfig :: ServerConfig
defaultServerConfig = ServerConfig {
adminConnector =
[ConnectorConfig {scheme=HTTP, port=8001, cert=Nothing, key=Nothing}]
, applicationConnector =
[ConnectorConfig {scheme=HTTP, port=8000, cert=Nothing, key=Nothing}]
}
printBanner :: IO ()
printBanner = do
banner <- lookupEnv bannerEnvName
putStr $ fromMaybe
"FIXME: failed to magic setBanner. son, I am disappoint\n"
banner
bannerEnvName :: String
bannerEnvName = "mclovin-banner-magic"
getDistribution :: Text -> EkgMetrics.Store -> IO Distribution
getDistribution = EkgMetrics.createDistribution
startServer :: ServerConfig -> EkgMetrics.Store -> Snap () -> IO ()
startServer
ServerConfig { applicationConnector, adminConnector }
metricsStore
snap
= do
mapM_ startMetricsServer adminConnector
httpServe snapConfig snap
where
startMetricsServer :: ConnectorConfig -> IO Server
startMetricsServer ConnectorConfig { scheme=HTTP, port } = do
registerGcMetrics metricsStore
debugM ("Starting up ekg on port: " ++ show port)
forkServerWith metricsStore "0.0.0.0" port
startMetricsServer ConnectorConfig { scheme=HTTPS } =
error "EKG does not support running on HTTPS"
snapConfig :: Config m a
snapConfig = mconcat $
map toSnapConfig applicationConnector ++ [
setAccessLog (ConfigIoLog (infoM "snap" . toString)) mempty,
setErrorLog (ConfigIoLog (errorM "snap" . toString)) mempty
]
where toString = T.unpack . decodeUtf8
toSnapConfig :: ConnectorConfig -> Config m a
toSnapConfig ConnectorConfig { scheme=HTTP, port } = setPort port mempty
toSnapConfig ConnectorConfig { scheme=HTTPS, port, cert=mcert, key=mkey } =
fromMaybe
(error "You must provide cert and key in order to use HTTPS.")
$ do
cert <- mcert
key <- mkey
return $ setSSLCert cert $ setSSLKey key $ setSSLPort port mempty
timedSnap :: Distribution -> Snap () -> Snap ()
timedSnap timer snap = do
start <- liftIO getCurrentTime
result <- snap
end <- liftIO getCurrentTime
addTiming start end
return result
where
addTiming start end = liftIO $
D.add timer diff
where
diff = toDouble (diffUTCTime end start)
toDouble = fromRational . toRational
debugM :: String -> IO ()
debugM = L.debugM "moonshine"