module Snap.Extension.Server
( ConfigExtend
, httpServe
, quickHttpServe
, defaultConfig
, getReloadHandler
, setReloadHandler
, module Snap.Http.Server.Config
) where
import Control.Exception (SomeException)
import Control.Monad
import Control.Monad.CatchIO
import Data.ByteString (ByteString)
import Data.Maybe
import Data.Monoid
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Prelude hiding (catch)
import Snap.Extension
import Snap.Http.Server (simpleHttpServe)
import qualified Snap.Http.Server.Config as C
import Snap.Http.Server.Config hiding ( defaultConfig
, completeConfig
, getOther
, setOther
)
import Snap.Util.GZip
import Snap.Types
import System.IO
type ConfigExtend s = Config
(SnapExtend s) (IO [(ByteString, Maybe ByteString)] -> SnapExtend s ())
getReloadHandler :: ConfigExtend s -> Maybe
(IO [(ByteString, Maybe ByteString)] -> SnapExtend s ())
getReloadHandler = C.getOther
setReloadHandler :: (IO [(ByteString, Maybe ByteString)] -> SnapExtend s ())
-> ConfigExtend s
-> ConfigExtend s
setReloadHandler = C.setOther
defaultConfig :: ConfigExtend s
defaultConfig = setReloadHandler handler C.defaultConfig
where
handler = path "admin/reload" . defaultReloadHandler
completeConfig :: ConfigExtend s -> ConfigExtend s
completeConfig c = case getListen c' of
[] -> addListen (ListenHttp "0.0.0.0" 8000) c'
_ -> c'
where c' = mappend defaultConfig c
httpServe :: ConfigExtend s
-> Initializer s
-> SnapExtend s ()
-> IO ()
httpServe config initializer handler = do
(snap, cleanup) <- runInitializerWithReloadAction
verbose
initializer
(catch500 handler)
reloader
let site = compress $ snap
mapM_ printListen $ C.getListen config
_ <- try $ serve $ site :: IO (Either SomeException ())
putStr "\n"
cleanup
output "Shutting down..."
where
conf = completeConfig config
verbose = fromJust $ getVerbose conf
output = when verbose . hPutStrLn stderr
reloader = fromJust $ getReloadHandler conf
compress = if fromJust $ getCompression conf then withCompression else id
catch500 = flip catch $ fromJust $ getErrorHandler conf
serve = simpleHttpServe config
listenToString (C.ListenHttp host port) =
concat ["http://", fromUTF8 host, ":", show port, "/"]
listenToString (C.ListenHttps host port _ _) =
concat ["https://", fromUTF8 host, ":", show port, "/"]
printListen l = output $ "Listening on " ++ listenToString l
quickHttpServe :: Initializer s
-> SnapExtend s ()
-> IO ()
quickHttpServe r m = commandLineConfig emptyConfig >>= \c -> httpServe c r m
fromUTF8 :: ByteString -> String
fromUTF8 = T.unpack . T.decodeUtf8