webapp 0.2.0 → 0.3.0
raw patch · 11 files changed
+130/−334 lines, 11 files
Files
- CHANGELOG.md +4/−0
- README.md +7/−26
- Web/App/HTTP.hs +43/−75
- Web/App/Internal/Daemon.hs +0/−108
- Web/App/Internal/Privileges.hs +0/−38
- Web/App/Main.hs +56/−70
- Web/App/Middleware/ForceSSL.hs +3/−2
- Web/App/RouteT.hs +1/−1
- Web/App/Stream.hs +13/−9
- Web/App/WebApp.hs +1/−1
- webapp.cabal +2/−4
CHANGELOG.md view
@@ -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.
README.md view
@@ -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.
Web/App/HTTP.hs view
@@ -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
− Web/App/Internal/Daemon.hs
@@ -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
− Web/App/Internal/Privileges.hs
@@ -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
Web/App/Main.hs view
@@ -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.")
Web/App/Middleware/ForceSSL.hs view
@@ -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)
Web/App/RouteT.hs view
@@ -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
Web/App/Stream.hs view
@@ -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
Web/App/WebApp.hs view
@@ -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
webapp.cabal view
@@ -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,