Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
149 lines (117 sloc) 4.89 KB
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE NoImplicitPrelude #-}
-- thanks, yesod :(
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
module Utils.Vigilance.Web.Yesod ( runServer
, WebApp(..) ) where
import ClassyPrelude
import Control.Lens
import Control.Monad ( (<=<) )
import Data.Acid (AcidState)
import Data.Time.Clock.POSIX ( getPOSIXTime
, POSIXTime )
import qualified Network.Wai as W
import Network.Wai.Handler.Warp (run)
import Network.HTTP.Types.Status (noContent204)
import Network.Wai.Middleware.Autohead
import Network.Wai.Middleware.AcceptOverride
import Network.Wai.Middleware.RequestLogger
import Network.Wai.Middleware.Gzip
import Network.Wai.Middleware.MethodOverride
import Utils.Vigilance.Config (configNotifiers)
import Utils.Vigilance.Logger ( runInLogCtx
, vLog )
import Utils.Vigilance.TableOps
import Utils.Vigilance.Types
import Utils.Vigilance.Workers.NotificationWorker (sendNotifications)
import Utils.Vigilance.Utils (bindM3)
import System.Log.FastLogger (LogStr(..))
import Yesod
data WebApp = WebApp { _acid :: AcidState AppState
, _cfg :: Config
, _logChan :: LogChan }
makeClassy ''WebApp
logCtxName :: Text
logCtxName = "Web"
-- stolen form yesod implementation. this needs to be public
lSToT :: LogStr -> Text
lSToT (LS s) = pack s
lSToT (LB s) = decodeUtf8 s
instance Yesod WebApp where
makeSessionBackend = const $ return Nothing
mkYesod "WebApp" [parseRoutes|
/watches WatchesR GET
/watches/#WatchName WatchR GET DELETE
/watches/#WatchName/pause PauseWatchR POST
/watches/#WatchName/unpause UnPauseWatchR POST
/watches/#WatchName/checkin CheckInWatchR POST
/watches/#WatchName/test TestWatchR POST
|]
getWatchesR :: Handler Value
getWatchesR = returnJson =<< allWatchesS =<< getDb
getWatchR :: WatchName -> Handler Value
getWatchR = jsonOrNotFound <=< onWatch findWatchS
deleteWatchR :: WatchName -> Handler Value
deleteWatchR name = onWatchExists deleteWatchS name >> noContent
postPauseWatchR :: WatchName -> Handler Value
postPauseWatchR name = onWatchExists pauseWatchS name >> noContent
postUnPauseWatchR :: WatchName -> Handler Value
postUnPauseWatchR name = onWatchExists unPause name >> noContent
where unPause db n = liftIO $ bindM3 unPauseWatchS (return db) getPOSIXTime (return n)
postCheckInWatchR :: WatchName -> Handler Value
postCheckInWatchR name = onWatchExists checkIn name >> noContent
where checkIn db n = liftIO $ bindM3 checkInWatchS (return db) getPOSIXTime (return n)
postTestWatchR :: WatchName -> Handler Value
postTestWatchR = maybe notFound doTest <=< onWatch findWatchS
where doTest w = do notifiers <- configNotifiers <$> getConfig
returnJson =<< inWebLogCtx (sendNotifications [w] notifiers)
noContent :: Handler Value
noContent = sendResponseStatus noContent204 ()
alwaysNoContent :: a -> Handler Value
alwaysNoContent = const noContent
jsonOrNotFound :: ToJSON a => Maybe a -> Handler Value
jsonOrNotFound = maybe notFound returnJson
runServer :: WebApp -> IO ()
runServer w = run port =<< toWaiApp' w
where port = w ^. cfg . configPort
toWaiApp' :: WebApp -> IO W.Application
toWaiApp' site = do
let ctx = LogCtx logCtxName $ site ^. logChan
middleware <- mkDefaultMiddlewares' ctx
middleware <$> toWaiAppPlain site
mkDefaultMiddlewares' :: LogCtx -> IO W.Middleware
mkDefaultMiddlewares' ctx = do
logWare <- mkRequestLogger def
{ destination = Callback cb
, outputFormat = Apache FromSocket
}
return $ logWare
. acceptOverride
. autohead
. gzip def
. methodOverride
where cb = runInLogCtx ctx . vLog . mconcat . map lSToT
getDb :: HandlerT WebApp IO (AcidState AppState)
getDb = view acid <$> getYesod
inWebLogCtx :: LogCtxT IO a -> HandlerT WebApp IO a
inWebLogCtx action = do
ctx <- LogCtx <$> pure logCtxName <*> getLogChan
liftIO $ runInLogCtx ctx action
getLogChan :: HandlerT WebApp IO LogChan
getLogChan = view logChan <$> getYesod
getConfig :: HandlerT WebApp IO Config
getConfig = view cfg <$> getYesod
onWatch :: (AcidState AppState -> WatchName -> HandlerT WebApp IO b) -> WatchName -> HandlerT WebApp IO b
onWatch f n = join $ f <$> getDb <*> pure n
onWatchExists :: (AcidState AppState -> WatchName -> HandlerT WebApp IO b) -> WatchName -> HandlerT WebApp IO b
onWatchExists f n = maybe notFound goAhead =<< checkExistence
where checkExistence = do db <- getDb
liftIO $ findWatchS db n
goAhead = const $ onWatch f n
getPOSIXTime' :: MonadIO m => m POSIXTime
getPOSIXTime' = liftIO getPOSIXTime