webapp 0.3.3 → 0.3.4
raw patch · 4 files changed
+22/−145 lines, 4 files
Files
- Web/App/Internal/IO.hs +0/−66
- Web/App/Internal/TerminalSize.hsc +0/−61
- Web/App/Main.hs +21/−14
- webapp.cabal +1/−4
− Web/App/Internal/IO.hs
@@ -1,66 +0,0 @@-{-|-Module : Web.App.IO-Copyright : (c) Nathaniel Symer, 2015-License : MIT-Maintainer : nate@symer.io-Stability : experimental-Portability : POSIX--Redirect standard input, output, and error. These functions will disable buffering-after they swap file handles because buffering causes funny behavior with respect-to writing to files. (buffering works fine with terminals/consoles).--}--module Web.App.Internal.IO-(- -- * IO Redirection- redirectStdin,- redirectStdout,- redirectStderr-)-where--import Control.Monad (when,void)--import System.IO-import System.Posix---- | Redirect standard input.-redirectStdin :: Maybe FilePath -- ^ File to which standard input is redirected- -> IO ()-redirectStdin Nothing = return ()-redirectStdin (Just path) = do- swapFd stdInput path- hSetBuffering stdin NoBuffering---- | Redirect standard output.-redirectStdout :: Maybe FilePath -- ^ File to which standard output is redirected- -> IO ()-redirectStdout Nothing = return ()-redirectStdout (Just path) = do- swapFd stdOutput path- hSetBuffering stdout NoBuffering---- | Redirect standard error.-redirectStderr :: Maybe FilePath -- ^ File to which standard error is redirected- -> IO ()-redirectStderr Nothing = return ()-redirectStderr (Just path) = do- swapFd stdError path- hSetBuffering stderr NoBuffering--{- Internal -}--safeOpenFd :: FilePath -> IO Fd-safeOpenFd p = do- exists <- fileExist p- when (not exists) $ writeFile p ""- fd <- openFd p ReadWrite Nothing defaultFileFlags- setFdOption fd AppendOnWrite True- return fd--swapFd :: Fd -> FilePath -> IO ()-swapFd old path = do- new <- safeOpenFd path- void $ dupTo new old- closeFd new
− Web/App/Internal/TerminalSize.hsc
@@ -1,61 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}--{-|-Module : Web.App.TerminalSize-License : MIT-Maintainer : nate@symer.io-Stability : experimental-Portability : POSIX--Get the size of the terminal. Adapted from http://stackoverflow.com/questions/12806053/get-terminal-width-haskell.--}--module Web.App.Internal.TerminalSize-(- -- * Terminal Size- getTermSize-)-where--import Foreign-import Foreign.C.Error-import Foreign.C.Types--import Control.Monad as M (void)--#include <sys/ioctl.h>-#include <unistd.h>---- Trick for calculating alignment of a type, taken from--- http://www.haskell.org/haskellwiki/FFICookBook#Working_with_structs-#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)---- @xpixel@ and @ypixel@ fields are unused,--- so they've been omitted.-data WinSize = WinSize CUShort CUShort -- row, col--instance Storable WinSize where- sizeOf _ = (#size struct winsize)- alignment _ = (#alignment struct winsize) - peek ptr = WinSize- <$> (#peek struct winsize, ws_row) ptr- <*> (#peek struct winsize, ws_col) ptr- poke ptr (WinSize row col) = do- (#poke struct winsize, ws_row) ptr row- (#poke struct winsize, ws_col) ptr col--foreign import ccall "sys/ioctl.h ioctl"- ioctl :: CInt -> CInt -> Ptr WinSize -> IO CInt---- | Get the size of the terminal.-getTermSize :: IO (Maybe (Int, Int)) -- ^ @(rows, columns)@-getTermSize = with (WinSize 0 0) $ \ws -> do- resetErrno- M.void $ ioctl (#const STDOUT_FILENO) (#const TIOCGWINSZ) ws- err <- getErrno- if isValidErrno err- then do- WinSize row col <- peek ws- return $ Just (fromIntegral row, fromIntegral col)- else return Nothing-
Web/App/Main.hs view
@@ -33,10 +33,9 @@ import Web.App.RouteT (RouteResult) import Web.App.State import Web.App.HTTP-import Web.App.Internal.IO-import Web.App.Internal.TerminalSize import Data.Maybe+import Control.Monad import Control.Monad.IO.Class import Control.Applicative@@ -44,7 +43,10 @@ import System.Posix import System.Exit import System.Environment+import System.IO +import GHC.IO.Handle+ import Text.Read data Options = Options {@@ -93,12 +95,11 @@ createSession forkProcess $ do getProcessID >>= writeFile pidFile . show- redirectStdout $ Just "/dev/null"- redirectStderr $ Just "/dev/null"- redirectStdin $ Just "/dev/null"- closeFd stdInput -- close STDIN+ redirectHandle stdout $ fromMaybe "/dev/null" o+ redirectHandle stderr $ fromMaybe "/dev/null" e+ redirectHandle stdin "/dev/null" installHandler sigHUP Ignore Nothing- start p c k o e+ start p c k Nothing Nothing exitImmediately ExitSuccess exitImmediately ExitSuccess start port cert key out err = do@@ -107,21 +108,27 @@ getRealGroupID >>= setEffectiveGroupID getRealUserID >>= setEffectiveUserID -- redirect I/O- redirectStdout out- redirectStderr err+ maybe (return ()) (redirectHandle stdout) out+ maybe (return ()) (redirectHandle stderr) 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- + redirectHandle hdl path = do+ exists <- fileExist path+ when (not exists) $ writeFile path ""+ h <- openFile path WriteMode+ hDuplicateTo h hdl+ hClose h+ hSetBuffering hdl NoBuffering+ parseArgs :: Maybe (Parser a) -> IO (Either a Options) parseArgs extra = do- w <- maybe 80 snd <$> getTermSize defaultPort <- ((=<<) readMaybe) <$> lookupEnv "PORT"- customExecParser (mkprefs w) $ info (helper <*> parser defaultPort) fullDesc+ customExecParser pprefs $ info (helper <*> parser defaultPort) fullDesc where- mkprefs = ParserPrefs "" False False True- parser port = (Right <$> parseStart port) <|> (maybe empty (fmap Left) extra)+ pprefs = ParserPrefs "" False False True 80+ parser port = (Right <$> parseStart port) <|> (maybe empty (fmap Left) extra)-- <|> (Right <$> showHelp) parseStart port = Options <$> (optional $ strOption $ long "daemonize" <> short 'd' <> metavar "FILEPATH" <> help "Daemonize server and write its pid to FILEPATH.") <*> (option auto $ long "port" <> short 'p' <> metavar "PORT" <> help "Run server on PORT." <> value (fromMaybe 3000 port))
webapp.cabal view
@@ -1,5 +1,5 @@ Name: webapp-Version: 0.3.3+Version: 0.3.4 Synopsis: Haskell web app framework based on WAI & Warp Homepage: https://github.com/fhsjaagshs/webapp Bug-reports: https://github.com/fhsjaagshs/webapp/issues@@ -17,7 +17,6 @@ Extra-source-files: README.md CHANGELOG.md Library- build-tools: hsc2hs ghc-options: -Wall -fno-warn-unused-do-bind Exposed-modules: Web.App Web.App.HTTP@@ -30,9 +29,7 @@ Web.App.RouteT Web.App.Stream Web.App.Main- Web.App.Internal.TerminalSize Web.App.WebApp- other-modules: Web.App.Internal.IO default-language: Haskell2010 build-depends: base <4.9, bytestring,