diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,3 +2,7 @@ v 0.0.1 - Initial release v 0.0.2 - Fix omitted module in `webapp.cabal`: `Web.App.Monad.Internal` +v 0.1.0 + - Included a new example: a counter app with an additional CLI parser. + - Implemented a "util" CLI subcommand where you can "mount" an optparse-applicative @Parser@. See example. + - Fixed termination handlers. Previously, they weren't installed when using HTTPS due to a bug in warp-tls. This has been remedied. Additionally, these handlers would destroy the initial state, rather than the current state from the @TVar@. diff --git a/Web/App.hs b/Web/App.hs --- a/Web/App.hs +++ b/Web/App.hs @@ -62,13 +62,17 @@ _passwordCmdPassword :: String } --- | Read commandline arguments and start app accordingly. +-- | Read commandline arguments and start app accordingly. When passing an +-- additional CLI parser, it is made available under the @util@ subcommand. webappMain :: (ScottyError e, WebAppState s) => ScottyT e (WebAppM s) () -- ^ app to start - -> String -- ^ CLI title - -> String -- ^ CLI description + -> String -- ^ CLI title/description + -> Maybe (Parser a) -- ^ extra CLI parser (available under @util@ subcommand) + -> (a -> IO ()) -- ^ action to apply to parse result of 'utilParser' -> IO () -webappMain app title desc = getArgs >>= getCommandArgs title desc >>= f +webappMain app title utilParser utilf = getArgs >>= getCommandArgs utilParser title >>= processArgs where + processArgs (Right cmd) = f cmd + processArgs (Left utils) = utilf utils f c@(StartCommand True _ _ _ _ _ _ pidPath) = do daemonize pidPath $ f $ c { startCmdDaemonize = False } f (StartCommand False False port crt key out err _) = do @@ -88,22 +92,19 @@ showStatus True = "running" showStatus False = "stopped" -getCommandArgs :: String -> String -> [String] -> IO Cmd -getCommandArgs title desc args = do +getCommandArgs :: Maybe (Parser a) -> String -> [String] -> IO (Either a Cmd) +getCommandArgs utilParser title args = do w <- maybe 80 snd <$> getTermSize handleParseResult $ execParserPure (pprefs w) parser args where pprefs = ParserPrefs "" False False True - parser = info (helper <*> parseCommand) (fullDesc <> progDesc desc <> header title) - -parseCommand :: Parser Cmd -parseCommand = sp <|> parseStart - where - sp = subparser $ (mkcmd "start" "Start the application server" parseStart) <> - (mkcmd "stop" "Stop the application server" parseStop) <> - (mkcmd "status" "Determine if the application server is running" parseStatus) <> - (mkcmd "password" "Make a BCrypt hash from a password" parseHash) - parseStart = StartCommand + parser = info (helper <*> ((sp utilParser) <|> parseStart)) (fullDesc <> header title) + sp Nothing = subparser subCommands + sp (Just util) = subparser $ subCommands <> (mkcmd "util" "Utilities associated with the application" (Left <$> util)) + subCommands = (mkcmd "start" "Start the application server" parseStart) <> + (mkcmd "stop" "Stop the application server" parseStop) <> + (mkcmd "status" "Determine if the application server is running" parseStatus) + parseStart = fmap Right $ StartCommand <$> (flag False True $ short 'd' <> long "daemonize" <> help "run the application server daemonized") <*> (flag False True $ short 'i' <> long "insecure" <> help "run the application server over insecure HTTP") <*> (option auto $ opt "port" 'p' "PORT" (Just 3000) "port to run the application server on") @@ -112,9 +113,8 @@ <*> (optional $ strOption $ opt "stdout" 'o' "FILEPATH" Nothing "redirect standard output to FILEPATH") <*> (optional $ strOption $ opt "stderr" 'e' "FILEPATH" Nothing "redirect standard error to FILEPATH") <*> (strOption $ opt "pid-file" 'z' "FILEPATH" (Just "/tmp/webapp.pid") "when daemonizing, write the PID to FILEPATH") - parseStop = StopCommand <$> (strOption $ opt "pid-file" 'z' "FILEPATH" (Just "/tmp/webapp.pid") "pid file") - parseStatus = StatusCommand <$> (strOption $ opt "pid-file" 'z' "FILEPATH" (Just "/tmp/webapp.pid") "pid file") - parseHash = PasswordCommand <$> (strArgument $ metavar "PASSWORD" <> help "password to hash") + parseStop = Right <$> StopCommand <$> (strOption $ opt "pid-file" 'z' "FILEPATH" (Just "/tmp/webapp.pid") "pid file") + parseStatus = Right <$> StatusCommand <$> (strOption $ opt "pid-file" 'z' "FILEPATH" (Just "/tmp/webapp.pid") "pid file") opt lng shrt mvar (Just defVal) hlp = (long lng <> short shrt <> metavar mvar <> value defVal <> help hlp) opt lng shrt mvar Nothing hlp = (long lng <> short shrt <> metavar mvar <> help hlp) mkcmd cmd desc p = command cmd $ info (helper <*> p) $ progDesc desc diff --git a/Web/App/HTTP.hs b/Web/App/HTTP.hs --- a/Web/App/HTTP.hs +++ b/Web/App/HTTP.hs @@ -36,10 +36,13 @@ import Network.Wai (responseLBS,requestHeaderHost,rawPathInfo,rawQueryString,Application) import Network.Wai.HTTP2 (promoteApplication,HTTP2Application) -import Network.Wai.Handler.Warp (defaultSettings,setPort,setBeforeMainLoop,setInstallShutdownHandler,runHTTP2Settings,Settings) -import Network.Wai.Handler.WarpTLS (certFile,defaultTlsSettings,keyFile,runHTTP2TLS) +import Network.Wai.Handler.Warp (defaultSettings,setPort,getPort,getHost,setBeforeMainLoop,setInstallShutdownHandler,runHTTP2Settings) +import Network.Wai.Handler.WarpTLS (certFile,defaultTlsSettings,keyFile,TLSSettings(..),runHTTP2TLSSocket) +import Network.Wai.Handler.Warp.Internal (Settings(..)) import Network.HTTP.Types.Status (status301) -import Network.Wai.Middleware.AddHeaders +import Network.Socket (sClose, withSocketsDo) +import Data.Streaming.Network (bindPortTCP) +import Control.Exception (bracket) import System.Exit import System.Posix @@ -48,10 +51,9 @@ startHTTP :: (ScottyError e, WebAppState s) => ScottyT e (WebAppM s) () -- ^ Scotty app to serve -> Int -- ^ Port to which to bind -> IO () -startHTTP app port = do - (wai,wai2,webapp) <- mkApplication app False - runHTTP2Settings (mkWarpSettings port webapp) wai2 wai +startHTTP app port = serveApp runHTTP2Settings app port +-- TODO: fix setInstallShutdownHandler not working -- |Start a secure HTTPS server. Please note that most HTTP/2-compatible browswers -- require HTTPS in order to upgrade to HTTP/2. startHTTPS :: (ScottyError e, WebAppState s) => ScottyT e (WebAppM s) () -- ^ Scotty app to serve @@ -61,34 +63,44 @@ -> IO () startHTTPS app port cert key = do whenPrivileged startRedirectProcess - (wai,wai2,webapp) <- mkApplication app True - runHTTP2TLS tlssettings (mkWarpSettings port webapp) wai2 wai - where tlssettings = defaultTlsSettings { keyFile = key, certFile = cert } + serveApp (runHTTP2TLSHandled tlsset) app port + where tlsset = defaultTlsSettings { keyFile = key, certFile = cert } + {- Internal -} - -mkWarpSettings :: (WebAppState s) => Int -> WebApp s -> Settings -mkWarpSettings port (WebApp cache st) = setBeforeMainLoop before - $ setInstallShutdownHandler shutdown - $ setPort port - defaultSettings + +serveApp :: (ScottyError e, WebAppState s) => (Settings -> HTTP2Application -> Application -> IO ()) -- ^ function to serve resulting app + -> ScottyT e (WebAppM s) () -- ^ scotty app to serve + -> Int -- ^ port to serve on + -> IO () +serveApp serve app port = do + st <- newTVarIO =<< (WebApp <$> (newFileCache "assets/") <*> initState)-- webapp + wai <- scottyAppT (\m -> runReaderT (runWebAppM m) st) $ do + middleware $ gzip 860 -- min length to GZIP + app + serve (warpSettings st) (promoteApplication wai) wai where + warpSettings tvar = setBeforeMainLoop before + $ setInstallShutdownHandler (installShutdown tvar) + $ setPort port defaultSettings before = resignPrivileges "daemon" - shutdown act = do - void $ act + installShutdown tvar killSockets = do + void $ installHandler sigTERM (handler tvar killSockets) Nothing + void $ installHandler sigINT (handler tvar killSockets) Nothing + handler tvar killSockets = Catch $ do + (WebApp cache st) <- readTVarIO tvar + void $ killSockets teardownFileCache cache destroyState st - -mkApplication :: (ScottyError e, WebAppState s) => ScottyT e (WebAppM s) () -> Bool -> IO (Application, HTTP2Application, WebApp s) -mkApplication app ssl = do - webapp <- WebApp <$> (newFileCache "assets/") <*> initState - sync <- newTVarIO webapp - let runActionToIO m = runReaderT (runWebAppM m) sync - wai <- scottyAppT runActionToIO $ do - middleware $ gzip 860 -- min length to GZIP - when ssl $ middleware $ addHeaders [("Strict-Transport-Security","max-age=31536000")] - app - return (wai, promoteApplication wai, webapp) + +-- | Serve an HTTP2 application over TLS, obeying 'settingsInstallShutdownHandler'. +-- This setting is ignored in WarpTLS due to a bug (gasp!). See +-- https://github.com/yesodweb/wai/issues/483 +runHTTP2TLSHandled :: TLSSettings -> Settings -> HTTP2Application -> Application -> IO () +runHTTP2TLSHandled tset set wai2 wai = withSocketsDo $ + bracket (bindPortTCP (getPort set) (getHost set)) sClose $ \socket -> do + settingsInstallShutdownHandler set (sClose socket) + runHTTP2TLSSocket tset set socket wai2 wai startRedirectProcess :: IO () startRedirectProcess = void $ do diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Web.App +import Web.Scotty.Trans +import Options.Applicative +import Network.HTTP.Types (Status(..)) +import Data.Text.Lazy (Text) +import qualified Data.ByteString.Lazy.Char8 as BL + +instance WebAppState Integer where + initState = return 0 + destroyState st = do + putStr "Counted: " + print st + +main :: IO () +main = webappMain app "My Web App" (Just parseUtil) handleUtil + +app :: ScottyT Text (WebAppM Integer) () +app = do + get "/" $ do + getState >>= raw . BL.pack . show + + get "/add" $ do + modifyState ((+) 1) + status $ Status 302 "" + setHeader "Location" "/" + + get "/subtract" $ do + count <- getState + putState $ count-1 + status $ Status 302 "" + setHeader "Location" "/" + + get "/assets/:file" $ param "file" >>= loadAsset + +data Util = Password String + +parseUtil :: Parser Util +parseUtil = subparser $ (mkcmd "password" "Hash a password" parsePassword) + where + parsePassword = Password <$> (strArgument $ metavar "PASSWORD" <> help "password to hash") + mkcmd cmd desc p = command cmd $ info (helper <*> p) $ progDesc desc + +handleUtil :: Util -> IO () +handleUtil (Password str) = putStrLn str diff --git a/webapp.cabal b/webapp.cabal --- a/webapp.cabal +++ b/webapp.cabal @@ -1,5 +1,5 @@ Name: webapp -Version: 0.0.2 +Version: 0.1.0 Synopsis: Haskell web scaffolding using Scotty, WAI, and Warp Homepage: https://github.com/fhsjaagshs/webapp Bug-reports: https://github.com/fhsjaagshs/webapp/issues @@ -19,8 +19,7 @@ CHANGELOG.md Library - build-tools: hsc2hs - other-modules: Web.App.TerminalSize + build-tools: hsc2hs, happy >= 1.19, alex >= 3.1.4 ghc-options: -Wall -O2 Exposed-modules: Web.App Web.App.Assets @@ -45,6 +44,8 @@ wai-extra, warp, warp-tls, + network, + streaming-commons, http-types, bytestring, data-default, @@ -67,6 +68,20 @@ filepath, directory, optparse-applicative + +executable example + default-language: Haskell2010 + main-is: Main.hs + hs-source-dirs: example + ghc-options: -threaded -Wall -O2 + build-depends: base, + transformers, + text, + bytestring, + scotty, + http-types, + optparse-applicative, + webapp source-repository head type: git