webapp 0.0.2 → 0.1.0
raw patch · 5 files changed
+128/−50 lines, 5 filesdep +networkdep +streaming-commonsdep +webappdep ~basenew-component:exe:example
Dependencies added: network, streaming-commons, webapp
Dependency ranges changed: base
Files
- CHANGELOG.md +4/−0
- Web/App.hs +19/−19
- Web/App/HTTP.hs +40/−28
- example/Main.hs +47/−0
- webapp.cabal +18/−3
CHANGELOG.md view
@@ -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@.
Web/App.hs view
@@ -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
Web/App/HTTP.hs view
@@ -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
+ example/Main.hs view
@@ -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
webapp.cabal view
@@ -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