diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -22,3 +22,7 @@ - Streaming body based around `writeBody` function - Allow data structures to be streamed via the 'ToStream' typeclass. - Typesafe parameter coersion + +v 0.2.1 + + - `stream` function can now optionally flush. `stream'` will always flush. This may improve list streaming functionality. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,32 +1,13 @@ # webapp - WAI web framework -Webapp is a web framework that is designed to provide everything needed to define & deploy a web app. +Webapp is a web framework that is designed to provide everything needed to define & deploy a web app. For how to use, see Haddock documentation. For an example, see `example.hs`. -Basic example: +Webapp provides a function called `webappMain` (as well as a series of other similarly named functions) that start the built-in webserver. Your web application's `main` function should include a call to one of them at the end. - module Main where - - import Web.App - import qualified Control.Monad.State.Class as S - - instance WebAppState Integer where - initState = return 0 - destroyState st = do - putStr "Counted: " - print st +# Using a webapp web app - main = webappMainIO' app "My Web App" +Once you've written your web app, deploying is up to you. Webapp will probably work with services like Heroku or complicated load balancers, but it designed to be a standalone server (i.e. no need to run behind something like nginx). - app :: WebAppT Integer IO () - app = do - get "/" $ do - addHeader "Content-Type" "text/plain" - S.get >>= writeBody . show - - get "/add" $ do - S.state (((),) . (+) 1) - redirect "/" - - get "/subtract" $ do - S.get >>= S.put . ((-) 1) - redirect "/" +Webapp works by first binding to an IPv4 TCP port, immediately after which resigning privileges†. Then it builds a `WAI` app from your `WebAppT` app, applies middleware, and runs `Warp`. + +† The effective GID & UID are set to match the real GID & UID. diff --git a/Web/App/HTTP.hs b/Web/App/HTTP.hs --- a/Web/App/HTTP.hs +++ b/Web/App/HTTP.hs @@ -13,92 +13,60 @@ module Web.App.HTTP ( - -- * Insecure HTTP - startHTTP, - -- * Secure HTTPS - startHTTPS + -- * Running Warp + runSecure, + runInsecure, + -- * Configuring Warp + mkWarpSettings, + -- * Bind to a TCP port for HTTP + bindTCP ) where -import Web.App.Middleware -import Web.App.Internal.Privileges -import Web.App.RouteT -import Web.App.State -import Web.App.WebApp - import Control.Monad -import Control.Monad.IO.Class -import Network.Wai (Application,Middleware) -import Network.Wai.Handler.Warp (defaultSettings,getPort,getHost,runSettings) +import Network.Wai (Application) +import Network.Wai.Handler.Warp (defaultSettings,runSettingsSocket,Port) import Network.Wai.Handler.WarpTLS (tlsSettings,runTLSSocket,TLSSettings(..),OnInsecure(..)) -import Network.Wai.Handler.Warp.Internal -- (Settings(..)) -import Network.Socket (sClose, withSocketsDo) +import Network.Wai.Handler.Warp.Internal +import Network.Socket (sClose,withSocketsDo,Socket) import Data.Streaming.Network (bindPortTCP) import Control.Exception (bracket) import System.Exit import System.Posix --- |Start an insecure HTTP server. -startHTTP :: (WebAppState s, MonadIO m) - => WebApp s m -- ^ Scotty app to serve - -> (m RouteResult -> IO RouteResult) -- ^ action to eval a monadic computation in @m@ in @IO@ - -> Int -- ^ Port to which to bind - -> IO () -startHTTP app runToIO port = serveApp runSettings runToIO app port [gzip 860] - --- |Start a secure HTTPS server. Please note that most HTTP/2-compatible browswers --- require HTTPS in order to upgrade to HTTP/2. -startHTTPS :: (WebAppState s, MonadIO m) - => WebApp s m -- ^ Scotty app to serve - -> (m RouteResult -> IO RouteResult) -- ^ action to eval a monadic computation in @m@ in @IO@ - -> Int -- ^ Port to which to bind - -> FilePath -- ^ 'FilePath' to an SSL certificate - -> FilePath -- ^ 'FilePath' to an SSL private key - -> IO () -startHTTPS app runToIO port cert key = serveApp (runTLSHandled tlsset) runToIO app port mw - where mw = [gzip 860, forceSSL] - tlsset = (tlsSettings cert key) { onInsecure = AllowInsecure } - -{- Internal -} +bindTCP :: Port -> (Socket -> IO ()) -> IO () +bindTCP port f = withSocketsDo $ bracket (bindPortTCP port "*4") sClose f --- |Serves a @'WebAppT' s m ()@ given a serving function, "dropping" --- function @(m 'RouteResult' -> 'IO' 'RouteResult')@, port, and middlewares. -serveApp :: (WebAppState s, MonadIO m) - => (Settings -> Application -> IO ()) -- ^ serving function - -> (m RouteResult -> IO RouteResult) -- ^ "dropping" function - -> WebApp s m -- ^ app to serve - -> Int -- ^ port to serve on - -> [Middleware] -- ^ middleware to add to the app - -> IO () -serveApp serve runToIO app port mws = do - (wai, teardown) <- toApplication runToIO $ mconcat $ app:map middleware mws - serve (warpSettings teardown) wai - where - warpSettings td = defaultSettings { - settingsPort = port, - settingsInstallShutdownHandler = installShutdown td, - settingsBeforeMainLoop = before, - settingsHTTP2Enabled = True -- explicitly enable HTTP2 support - } - before = resignPrivileges "daemon" - installShutdown teardown killSockets = do - void $ installHandler sigTERM (handler teardown killSockets) Nothing - void $ installHandler sigINT (handler teardown killSockets) Nothing - handler teardown killSockets = Catch $ do - void $ killSockets - void $ teardown - exitImmediately ExitSuccess +-- |Build a Warp Settings struct +mkWarpSettings :: IO () -- ^ function to be called on a SIGTERM or SIGINT + -> Int -- ^ port + -> Settings +mkWarpSettings teardown port = defaultSettings { + settingsHTTP2Enabled = True, -- explicitly enable HTTP2 support + settingsPort = port, + settingsInstallShutdownHandler = \killSockets -> void $ do + installHandler sigTERM (handler $ killSockets >> teardown) Nothing + installHandler sigINT (handler $ killSockets >> teardown) Nothing + } + where handler = Catch . (>> exitImmediately ExitSuccess) + +-- |Serve a WAI app using Warp over TLS. +runSecure :: FilePath -- ^ 'FilePath' to an SSL certificate + -> FilePath -- ^ 'FilePath' to an SSL private key + -> Socket -- ^ Socket to use + -> Settings -- ^ Warp settings structure + -> Application -- ^ WAI application + -> IO () +runSecure cert key sock set app = do + settingsInstallShutdownHandler set (sClose sock) -- ignored by Warp's @runTLSSocket@ + runTLSSocket tset set sock app + where tset = (tlsSettings cert key) { onInsecure = AllowInsecure } --- |Serve an application over TLS, obeying 'settingsInstallShutdownHandler'. --- This setting is ignored in WarpTLS due to a bug (gasp!). See --- https://github.com/yesodweb/wai/issues/483 -runTLSHandled :: TLSSettings -> Settings -> Application -> IO () -runTLSHandled tset set wai = withSocketsDo $ bracket acquire destroy f - where - acquire = bindPortTCP (getPort set) (getHost set) - destroy = sClose - f socket = do - settingsInstallShutdownHandler set (sClose socket) - runTLSSocket tset set socket wai +-- |Serve a WAI app using Warp over unencrypted HTTP. +runInsecure :: Socket -- ^ Socket to use + -> Settings -- ^ Warp settings structure + -> Application -- ^ WAI application + -> IO () +runInsecure = flip runSettingsSocket diff --git a/Web/App/Internal/Daemon.hs b/Web/App/Internal/Daemon.hs deleted file mode 100644 --- a/Web/App/Internal/Daemon.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-| -Module : Web.App.Daemon -Copyright : (c) Nathaniel Symer, 2015 -License : MIT -Maintainer : nate@symer.io -Stability : experimental -Portability : POSIX - -Operations related to running a background process --} - -module Web.App.Internal.Daemon -( - -- * Daemon Operations - daemonize, - daemonRunning, - daemonKill, - pidWrite, - pidRead, - pidKill, - pidLive -) -where - -import Web.App.Internal.IO - -import Control.Exception -import Control.Monad (when,void) - -import System.Exit -import System.Posix - --- |Kill a daemon -daemonKill :: Int -- ^ Timeout - -> FilePath -- ^ 'FilePath' of a PID file - -> IO () -daemonKill = pidKill - --- |Determine if a daemon is still running -daemonRunning :: FilePath -- ^ 'FilePath' of a PID file - -> IO Bool -daemonRunning pidFile = fileExist pidFile >>= f - where - f False = return False - f True = pidRead pidFile >>= g - g Nothing = return False - g (Just pid) = pidLive pid - --- |Start a daemonized process -daemonize :: FilePath -- ^ 'FilePath' of a PID file - -> IO () -- ^ Action to execute daemonized - -> IO () -daemonize pidFile program = do - void $ forkProcess $ do - void $ createSession - void $ forkProcess $ do - pidWrite pidFile - redirectStdout $ Just "/dev/null" - redirectStderr $ Just "/dev/null" - redirectStdin $ Just "/dev/null" - closeFd stdInput -- close STDIN - void $ installHandler sigHUP Ignore Nothing - program - exitImmediately ExitSuccess - exitImmediately ExitSuccess - --- Wait for a process to exit --- if it is still running after @secs@ --- seconds, "shoot it in the head" -wait :: Int -> CPid -> IO () -wait secs pid = (when <$> pidLive pid) >>= \w -> w f - where f | secs > 0 = do - usleep 1000000 -- sleep for 1 second - wait (secs-1) pid - | otherwise = do - putStrLn $ "force killing PID " ++ (show pid) - signalProcess sigKILL pid - --- |Write the process's PID to a file -pidWrite :: FilePath -> IO () -pidWrite pidPath = getProcessID >>= writeFile pidPath . show - --- |Read a PID from a file -pidRead :: FilePath -> IO (Maybe CPid) -pidRead pidFile = fileExist pidFile >>= f where - f True = fmap (Just . read) . readFile $ pidFile - f False = return Nothing - --- |Determine if a PID is live -pidLive :: CPid -> IO Bool -pidLive pid = (getProcessPriority pid >> return True) `catch` f where - f :: IOException -> IO Bool - f _ = return False - --- |Kill a PID from a file with a timeout -pidKill :: Int -> FilePath -> IO () -pidKill timeout pidFile = fileExist pidFile >>= f - where - f False = return () - f True = do - pidRead pidFile >>= g - removeLink pidFile - g Nothing = return () - g (Just pid) = pidLive pid >>= h pid - h _ False = return () - h pid True = do - signalProcess sigTERM pid - wait timeout pid diff --git a/Web/App/Internal/Privileges.hs b/Web/App/Internal/Privileges.hs deleted file mode 100644 --- a/Web/App/Internal/Privileges.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-| -Module : Web.App.Privileges -Copyright : (c) Nathaniel Symer, 2015 -License : MIT -Maintainer : nate@symer.io -Stability : experimental -Portability : POSIX - -Determine when the process is being ran as root. --} - -module Web.App.Internal.Privileges -( - isPrivileged, - whenPrivileged, - resignPrivileges -) -where - -import Control.Monad -import System.Posix - --- | Determine if the process is being ran as root -isPrivileged :: IO Bool -isPrivileged = ((==) 0) <$> getEffectiveUserID - --- | Perform an action when ran as root -whenPrivileged :: IO () -- ^ The action to be performed - -> IO () -whenPrivileged act = do - privileged <- isPrivileged - when privileged act - --- | Drop root privileges -resignPrivileges :: String -- ^ Name of user to "become" - -> IO () -resignPrivileges user = whenPrivileged $ do - getUserEntryForName user >>= setUserID . userID diff --git a/Web/App/Main.hs b/Web/App/Main.hs --- a/Web/App/Main.hs +++ b/Web/App/Main.hs @@ -34,44 +34,34 @@ import Web.App.State import Web.App.HTTP import Web.App.Internal.IO -import Web.App.Internal.Daemon import Web.App.Internal.TerminalSize +import Data.Maybe import Control.Monad.IO.Class import Control.Applicative import Options.Applicative -import System.Environment (getArgs) +import System.Posix +import System.Exit -data Cmd - = StartCommand { - startCmdDaemonize :: Bool, - _startCmdInsecure :: Bool, - _startCmdPort :: Int, - _startCmdHTTPSSLCert :: FilePath, - _startCmdHTTPSSLKey :: FilePath, - _startCmdOutputPath :: Maybe FilePath, - _startCmdErrorPath :: Maybe FilePath, - _startCmdPidPath :: FilePath - } - | StopCommand { - _stopCmdPidPath :: FilePath - } - | StatusCommand { - _statusCmdPidPath :: FilePath - } - +data Options = Options { + _optionsDaemonize :: Maybe FilePath, + _optionsPort :: Int, + _optionsHTTPSSLCert :: Maybe FilePath, + _optionsHTTPSSLKey :: Maybe FilePath, + _optionsOutputPath :: Maybe FilePath, + _optionsErrorPath :: Maybe FilePath +} + -- |Like 'webappMainIO' without the CLI extension arguments. webappMainIO' :: (WebAppState s) => WebApp s IO -- ^ app to start - -> String -- ^ CLI title/description -> IO () -webappMainIO' a d = webappMainIO a d Nothing (const $ return ()) +webappMainIO' a = webappMainIO a Nothing (const $ return ()) -- |Run a webapp based on IO. webappMainIO :: (WebAppState s) => WebApp s IO -- ^ app to start - -> 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 () @@ -81,61 +71,57 @@ webappMain' :: (WebAppState s, MonadIO m) => (m RouteResult -> IO RouteResult) -- ^ action to eval a monadic computation in @m@ in @IO@ -> WebApp s m -- ^ app to start - -> String -- ^ CLI title/description -> IO () -webappMain' f a d = webappMain f a d Nothing (const $ return ()) +webappMain' f a = webappMain f a Nothing (const $ return ()) -- | Read commandline arguments and start webapp accordingly. When passing an -- additional CLI parser, it is made available under the @util@ subcommand. webappMain :: (WebAppState s, MonadIO m) => (m RouteResult -> IO RouteResult) -- ^ action to eval a monadic computation in @m@ in @IO@ -> WebApp s m -- ^ app to start - -> String -- ^ CLI title/description - -> Maybe (Parser a) -- ^ extra CLI parser (available under @util@ subcommand) - -> (a -> IO ()) -- ^ action to apply to parse result of 'utilParser' + -> Maybe (Parser a) -- ^ extra CLI parser, parsed after the built-in parser + -> (a -> IO ()) -- ^ action to apply the result of 'extraParser' -> IO () -webappMain runToIO app title utilParser utilf = getArgs >>= getCommandArgs utilParser title >>= processArgs +webappMain runToIO app extraParser extraf = parseArgs extraParser >>= either extraf f 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 - redirectStdout out - redirectStderr err - startHTTPS app runToIO port crt key - f (StartCommand False True port _ _ out err _) = do - redirectStdout out - redirectStderr err - startHTTP app runToIO port - f (StopCommand pidPath) = daemonKill 4 pidPath - f (StatusCommand pidPath) = daemonRunning pidPath >>= putStrLn . showStatus - showStatus True = "running" - showStatus False = "stopped" - -getCommandArgs :: Maybe (Parser a) -> String -> [String] -> IO (Either a Cmd) -getCommandArgs utilParser title args = do + f (Options Nothing p c k o e) = start p c k o e + f (Options (Just pidFile) p c k o e) = do + forkProcess $ do + createSession + forkProcess $ do + getProcessID >>= writeFile pidFile . show + redirectStdout $ Just "/dev/null" + redirectStderr $ Just "/dev/null" + redirectStdin $ Just "/dev/null" + closeFd stdInput -- close STDIN + installHandler sigHUP Ignore Nothing + start p c k o e + exitImmediately ExitSuccess + exitImmediately ExitSuccess + start port cert key out err = do + bindTCP port $ \sock -> do + -- drop privileges after binding to a port + getRealGroupID >>= setEffectiveGroupID + getRealUserID >>= setEffectiveUserID + -- redirect I/O + redirectStdout out + redirectStderr err + -- serve webapp + (wai,teardown) <- toApplication runToIO app + serveFunc cert key sock (mkWarpSettings teardown port) wai + where serveFunc c k = fromMaybe runInsecure $ runSecure <$> c <*> k + +parseArgs :: Maybe (Parser a) -> IO (Either a Options) +parseArgs extra = do w <- maybe 80 snd <$> getTermSize - handleParseResult $ execParserPure (pprefs w) parser args + customExecParser (mkprefs w) $ info (helper <*> parser) fullDesc where - pprefs = ParserPrefs "" False False True - 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") - <*> (strOption $ opt "https-crt" 'c' "FILEPATH" (Just "server.crt") "SSL certificate file") - <*> (strOption $ opt "https-key" 'k' "FILEPATH" (Just "server.key") "SSL private key file") - <*> (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 = 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 + mkprefs = ParserPrefs "" False False True + parser = (Right <$> parseStart) <|> (maybe empty (fmap Left) extra) + parseStart = Options + <$> (option auto $ long "port" <> short 'p' <> metavar "PORT" <> help "Run server on PORT." <> value 3000) + <*> (optional $ strOption $ long "daemonize" <> short 'd' <> metavar "FILEPATH" <> help "Daemonize server and write its pid to FILEPATH.") + <*> (optional $ strOption $ long "ssl-cert" <> short 'c' <> metavar "FILEPATH" <> help "SSL certificate file. If a certificate and key are provided, the server will be run secure.") + <*> (optional $ strOption $ long "ssl-key" <> short 'k' <> metavar "FILEPATH" <> help "SSL private key file. If a certificate and key are provided, the server will be run secure.") + <*> (optional $ strOption $ long "output-log" <> short 'o' <> metavar "FILEPATH" <> help "Redirect output to FILEPATH.") + <*> (optional $ strOption $ long "error-log" <> short 'e' <> metavar "FILEPATH" <> help "Redirect error to FILEPATH.") diff --git a/Web/App/Middleware/ForceSSL.hs b/Web/App/Middleware/ForceSSL.hs --- a/Web/App/Middleware/ForceSSL.hs +++ b/Web/App/Middleware/ForceSSL.hs @@ -21,9 +21,10 @@ import Data.Monoid import Network.HTTP.Types.Status (status301) +-- TODO: specify port -- |Middleware to force SSL traffic. -forceSSL :: Middleware -forceSSL app = \req respond -> if isSecure req +forceSSL :: Int -> Middleware +forceSSL port app = \req respond -> if isSecure req then app req respond else let url = "https://" <> (fromJust $ requestHeaderHost req) diff --git a/Web/App/RouteT.hs b/Web/App/RouteT.hs --- a/Web/App/RouteT.hs +++ b/Web/App/RouteT.hs @@ -215,7 +215,7 @@ -- |Write a 'Stream' to the response body. writeBody :: (WebAppState s, Monad m, ToStream w) => w -> RouteT s m () writeBody w = RouteT $ \_ _ _ _ -> - return $ Right ((),Nothing,[],Just $ stream w) + return $ Right ((),Nothing,[],Just $ stream' w) -- |Same as 'writeBody', but designed for use -- with literals via OverloadedStrings diff --git a/Web/App/Stream.hs b/Web/App/Stream.hs --- a/Web/App/Stream.hs +++ b/Web/App/Stream.hs @@ -48,28 +48,32 @@ -- |Turn data into a WAI stream. class ToStream a where - stream :: a -> Stream + stream :: Bool -> a -> Stream -- ^ stream with the option to flush + stream' :: a -> Stream -- ^ stream and flush + stream' = stream True instance (ToStream a) => ToStream [a] where - stream = mconcat . map stream + stream True b = (stream False b) <> flusher + stream False b = mconcat $ map (stream False) b instance ToStream () where - stream _ = mempty + stream _ _ = mempty instance ToStream Builder where - stream b = Stream $ \w f -> w b >> f + stream False b = Stream $ \w _ -> w b + stream True b = Stream $ \w f -> w b >> f instance ToStream Char where - stream = stream . fromChar + stream f = stream f . fromChar instance ToStream T.Text where - stream = stream . T.encodeUtf8 + stream f = stream f . T.encodeUtf8 instance ToStream TL.Text where - stream = stream . TL.encodeUtf8 + stream f = stream f . TL.encodeUtf8 instance ToStream B.ByteString where - stream = stream . fromByteString + stream f = stream f . fromByteString instance ToStream BL.ByteString where - stream = stream . fromLazyByteString + stream f = stream f . fromLazyByteString diff --git a/Web/App/WebApp.hs b/Web/App/WebApp.hs --- a/Web/App/WebApp.hs +++ b/Web/App/WebApp.hs @@ -52,7 +52,7 @@ -- |Turn a 'WebAppT' computation into a WAI 'Application'. toApplication :: (WebAppState s, MonadIO m, MonadIO n) - => (m RouteResult -> IO RouteResult) -- ^ fnc eval a monadic computation in @m@ in @IO@ + => (m RouteResult -> IO RouteResult) -- ^ function to run WebApp-transformed monad m to IO -> WebApp s m -- ^ a web app -> n (Application, -- ^ WAI application IO ()) -- ^ teardown action; call when shutting down app server diff --git a/webapp.cabal b/webapp.cabal --- a/webapp.cabal +++ b/webapp.cabal @@ -1,5 +1,5 @@ Name: webapp -Version: 0.2.0 +Version: 0.3.0 Synopsis: Haskell web app framework based on WAI & Warp Homepage: https://github.com/fhsjaagshs/webapp Bug-reports: https://github.com/fhsjaagshs/webapp/issues @@ -18,7 +18,7 @@ Library build-tools: hsc2hs - ghc-options: -Wall + ghc-options: -Wall -fno-warn-unused-do-bind Exposed-modules: Web.App Web.App.HTTP Web.App.State @@ -33,8 +33,6 @@ Web.App.Internal.TerminalSize Web.App.WebApp other-modules: Web.App.Internal.IO - Web.App.Internal.Daemon - Web.App.Internal.Privileges default-language: Haskell2010 build-depends: base >= 4.8.0.0 && <= 4.8.1.0, bytestring,