webapp 0.1.1 → 0.1.2
raw patch · 10 files changed
+144/−220 lines, 10 filesdep −bcryptdep −webappdep ~base
Dependencies removed: bcrypt, webapp
Dependency ranges changed: base
Files
- Web/App.hs +3/−11
- Web/App/Daemon.hs +24/−15
- Web/App/Gzip.hs +0/−59
- Web/App/HTTP.hs +13/−40
- Web/App/Middleware.hs +9/−0
- Web/App/Middleware/ForceSSL.hs +31/−0
- Web/App/Middleware/Gzip.hs +59/−0
- Web/App/Password.hs +0/−29
- example/Main.hs +0/−47
- webapp.cabal +5/−19
Web/App.hs view
@@ -19,9 +19,9 @@ module Web.App.Daemon, module Web.App.FileCache, module Web.App.HTTP,- module Web.App.Password, module Web.App.IO,- module Web.App.Monad+ module Web.App.Monad,+ module Web.App.Middleware ) where @@ -30,16 +30,15 @@ import Web.App.Daemon import Web.App.FileCache import Web.App.HTTP-import Web.App.Password import Web.App.IO import Web.App.Monad import Web.App.TerminalSize+import Web.App.Middleware import Control.Applicative import Options.Applicative import System.Environment (getArgs) import Web.Scotty.Trans (ScottyT,ScottyError)-import System.IO data Cmd = StartCommand {@@ -58,9 +57,6 @@ | StatusCommand { _statusCmdPidPath :: FilePath }- | PasswordCommand {- _passwordCmdPassword :: String- } -- | Read commandline arguments and start app accordingly. When passing an -- additional CLI parser, it is made available under the @util@ subcommand.@@ -85,10 +81,6 @@ startHTTP app port f (StopCommand pidPath) = daemonKill 4 pidPath f (StatusCommand pidPath) = daemonRunning pidPath >>= putStrLn . showStatus- f (PasswordCommand pwd) = hashPassword pwd >>= g- where- g (Just v) = putStrLn v- g Nothing = hPutStrLn stderr "failed to hash password" showStatus True = "running" showStatus False = "stopped"
Web/App/Daemon.hs view
@@ -14,7 +14,11 @@ -- * Daemon Operations daemonize, daemonRunning,- daemonKill+ daemonKill,+ pidWrite,+ pidRead,+ pidKill,+ pidLive ) where @@ -30,18 +34,7 @@ daemonKill :: Int -- ^ Timeout -> FilePath -- ^ 'FilePath' of a PID file -> IO ()-daemonKill 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+daemonKill = pidKill -- |Determine if a daemon is still running daemonRunning :: FilePath -- ^ 'FilePath' of a PID file@@ -71,8 +64,6 @@ exitImmediately ExitSuccess exitImmediately ExitSuccess -{- Internal -}- -- Wait for a process to exit -- if it is still running after @secs@ -- seconds, "shoot it in the head"@@ -85,15 +76,33 @@ 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/Gzip.hs
@@ -1,59 +0,0 @@-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}-{-|-Module : Web.App.Gzip-Copyright : (c) Nathaniel Symer, 2015-License : MIT-Maintainer : nate@symer.io-Stability : experimental-Portability : Cross-Platform--WAI middleware to GZIP HTTP responses.--}--module Web.App.Gzip-(- gzip-)-where--import Network.Wai-import Network.Wai.Header-import Network.Wai.Internal-import Data.Maybe (fromMaybe,isJust)-import qualified Codec.Compression.GZip as GZIP (compress)-import qualified Data.ByteString.Char8 as B (ByteString,isInfixOf,break,drop,dropWhile)-import Blaze.ByteString.Builder (toLazyByteString)-import Blaze.ByteString.Builder.ByteString (fromLazyByteString)---- | Creates a 'Middleware' that GZIPs HTTP responses-gzip :: Integer -- ^ Minimum response length that's GZIP'd- -> Middleware-gzip minLen app env sendResponse = app env f- where- f res@ResponseRaw{} = sendResponse res- f res- | isCompressable res = compressResponse res sendResponse- | otherwise = sendResponse res- isCompressable res = isAccepted && not isMSIE6 && (not $ isEncoded res) && isBigEnough res- isAccepted = fromMaybe False . fmap acceptsGZIP . lookup "Accept-Encoding" . requestHeaders $ env- isMSIE6 = fromMaybe False . fmap (B.isInfixOf "MSIE 6") . lookup "User-Agent" . requestHeaders $ env- isEncoded = isJust . lookup "Content-Encoding" . responseHeaders- isBigEnough = maybe True ((<=) minLen) . contentLength . responseHeaders---- TODO: ensure original flushing action is eval'd-compressResponse :: Response -> (Response -> IO a) -> IO a-compressResponse res sendResponse = f $ lookup "Content-Type" hs- where- (s,hs,wb) = responseToStream res- hs' = (++) [("Vary","Accept-Encoding"),("Content-Encoding","gzip")] . filter ((/=) "Content-Length" . fst) $ hs- f (Just _) = wb $ \b -> sendResponse $ responseStream s hs' $ \w fl -> b (writeCompressed w) fl- f _ = sendResponse res- writeCompressed w = w . fromLazyByteString . GZIP.compress . toLazyByteString--acceptsGZIP :: B.ByteString -> Bool-acceptsGZIP "" = False-acceptsGZIP x = if y == "gzip"- then True- else acceptsGZIP $ skipSpace z- where (y,z) = B.break (== ',') x- skipSpace = B.dropWhile (== ' ') . B.drop 1
Web/App/HTTP.hs view
@@ -22,24 +22,21 @@ import Web.App.Monad import Web.App.Monad.Internal-import Web.App.IO import Web.App.FileCache-import Web.App.Gzip+import Web.App.Middleware import Web.App.Privileges -import Data.Maybe import Control.Monad import Control.Monad.Reader (runReaderT) import Control.Concurrent.STM import Web.Scotty.Trans as Scotty -import Network.Wai (responseLBS,requestHeaderHost,rawPathInfo,rawQueryString,Application)+import Network.Wai (Application,Middleware) import Network.Wai.HTTP2 (promoteApplication,HTTP2Application) 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.WarpTLS (certFile,defaultTlsSettings,keyFile,TLSSettings(..),runHTTP2TLSSocket,OnInsecure(..)) import Network.Wai.Handler.Warp.Internal (Settings(..))-import Network.HTTP.Types.Status (status301) import Network.Socket (sClose, withSocketsDo) import Data.Streaming.Network (bindPortTCP) import Control.Exception (bracket)@@ -51,7 +48,7 @@ startHTTP :: (ScottyError e, WebAppState s) => ScottyT e (WebAppM s) () -- ^ Scotty app to serve -> Int -- ^ Port to which to bind -> IO ()-startHTTP app port = serveApp runHTTP2Settings app port+startHTTP app port = serveApp runHTTP2Settings app port [gzip 860] -- TODO: fix setInstallShutdownHandler not working -- |Start a secure HTTPS server. Please note that most HTTP/2-compatible browswers@@ -62,21 +59,23 @@ -> FilePath -- ^ 'FilePath' to an SSL private key -> IO () startHTTPS app port cert key = do- whenPrivileged startRedirectProcess- serveApp (runHTTP2TLSHandled tlsset) app port- where tlsset = defaultTlsSettings { keyFile = key, certFile = cert }+ serveApp (runHTTP2TLSHandled tlsset) app port [gzip 860, forceSSL]+ where tlsset = defaultTlsSettings { keyFile = key, certFile = cert, onInsecure = AllowInsecure } {- Internal -} -serveApp :: (ScottyError e, WebAppState s) => (Settings -> HTTP2Application -> Application -> IO ()) -- ^ function to serve resulting app+serveApp :: (ScottyError e, WebAppState s) => (Settings -> HTTP2Application -> Application -> IO ()) -- ^ fnc to serve resulting app -> ScottyT e (WebAppM s) () -- ^ scotty app to serve -> Int -- ^ port to serve on+ -> [Middleware] -> IO ()-serveApp serve app port = do+serveApp serve app port middlewares = do st <- newTVarIO =<< (WebApp <$> (newFileCache "assets/") <*> initState)-- webapp wai <- scottyAppT (\m -> runReaderT (runWebAppM m) st) $ do+ mapM_ middleware middlewares middleware $ gzip 860 -- min length to GZIP+ middleware $ forceSSL app serve (warpSettings st) (promoteApplication wai) wai where@@ -100,31 +99,5 @@ 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- putStrLn "starting HTTP -> HTTPS process"- -- TODO: improve separation from parent process- pid <- forkProcess $ do- redirectStdout $ Just "/dev/null"- redirectStderr $ Just "/dev/null"- redirectStdin $ Just "/dev/null"- void $ installHandler sigTERM (Catch childHandler) Nothing- runHTTP2Settings warpSettings (promoteApplication app) app- - void $ installHandler sigTERM (Catch $ parentHandler pid) Nothing- void $ installHandler sigINT (Catch $ parentHandler pid) Nothing- where- warpSettings = setBeforeMainLoop (resignPrivileges "daemon") $ setPort 80 defaultSettings- mkHeaders r = [("Location", url r)]- host = fromJust . requestHeaderHost- url r = mconcat ["https://", host r, rawPathInfo r, rawQueryString r]- childHandler = exitImmediately ExitSuccess- parentHandler pid = do- putStrLn "killing HTTP -> HTTPS process"- signalProcess sigTERM pid- exitImmediately ExitSuccess- app req respond = respond $ responseLBS status301 (mkHeaders req) ""- + settingsInstallShutdownHandler set (sClose socket)+ runHTTP2TLSSocket tset set socket wai2 wai
+ Web/App/Middleware.hs view
@@ -0,0 +1,9 @@+module Web.App.Middleware+(+ module Web.App.Middleware.Gzip,+ module Web.App.Middleware.ForceSSL+)+where++import Web.App.Middleware.Gzip+import Web.App.Middleware.ForceSSL
+ Web/App/Middleware/ForceSSL.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}+{-|+Module : Web.App.Middleware.ForceSSL+Copyright : (c) Nathaniel Symer, 2015+License : MIT+Maintainer : nate@symer.io+Stability : experimental+Portability : Cross-Platform++WAI middlware to force ssl.+-}++module Web.App.Middleware.ForceSSL+(+ forceSSL+)+where++import Network.Wai+import Data.Maybe (fromJust)+import Data.Monoid+import Network.HTTP.Types.Status (status301)++forceSSL :: Middleware+forceSSL app = \req respond -> if isSecure req+ then app req respond+ else let url = "https://"+ <> (fromJust $ requestHeaderHost req)+ <> rawPathInfo req+ <> rawQueryString req+ in respond $ responseLBS status301 [("Location", url)] ""
+ Web/App/Middleware/Gzip.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}+{-|+Module : Web.App.Gzip+Copyright : (c) Nathaniel Symer, 2015+License : MIT+Maintainer : nate@symer.io+Stability : experimental+Portability : Cross-Platform++WAI middleware to GZIP HTTP responses.+-}++module Web.App.Middleware.Gzip+(+ gzip+)+where++import Network.Wai+import Network.Wai.Header+import Network.Wai.Internal+import Data.Maybe (fromMaybe,isJust)+import qualified Codec.Compression.GZip as GZIP (compress)+import qualified Data.ByteString.Char8 as B (ByteString,isInfixOf,break,drop,dropWhile)+import Blaze.ByteString.Builder (toLazyByteString)+import Blaze.ByteString.Builder.ByteString (fromLazyByteString)++-- | Creates a 'Middleware' that GZIPs HTTP responses+gzip :: Integer -- ^ Minimum response length that's GZIP'd+ -> Middleware+gzip minLen app env sendResponse = app env f+ where+ f res@ResponseRaw{} = sendResponse res+ f res+ | isCompressable res = compressResponse res sendResponse+ | otherwise = sendResponse res+ isCompressable res = isAccepted && not isMSIE6 && (not $ isEncoded res) && isBigEnough res+ isAccepted = fromMaybe False . fmap acceptsGZIP . lookup "Accept-Encoding" . requestHeaders $ env+ isMSIE6 = fromMaybe False . fmap (B.isInfixOf "MSIE 6") . lookup "User-Agent" . requestHeaders $ env+ isEncoded = isJust . lookup "Content-Encoding" . responseHeaders+ isBigEnough = maybe True ((<=) minLen) . contentLength . responseHeaders++-- TODO: ensure original flushing action is eval'd+compressResponse :: Response -> (Response -> IO a) -> IO a+compressResponse res sendResponse = f $ lookup "Content-Type" hs+ where+ (s,hs,wb) = responseToStream res+ hs' = (++) [("Vary","Accept-Encoding"),("Content-Encoding","gzip")] . filter ((/=) "Content-Length" . fst) $ hs+ f (Just _) = wb $ \b -> sendResponse $ responseStream s hs' $ \w fl -> b (writeCompressed w) fl+ f _ = sendResponse res+ writeCompressed w = w . fromLazyByteString . GZIP.compress . toLazyByteString++acceptsGZIP :: B.ByteString -> Bool+acceptsGZIP "" = False+acceptsGZIP x = if y == "gzip"+ then True+ else acceptsGZIP $ skipSpace z+ where (y,z) = B.break (== ',') x+ skipSpace = B.dropWhile (== ' ') . B.drop 1
− Web/App/Password.hs
@@ -1,29 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--{-|-Module : Web.App.Password-Copyright : (c) Nathaniel Symer, 2015-License : MIT-Maintainer : nate@symer.io-Stability : experimental-Portability : POSIX--Generate BCrypt hashes.--}--module Web.App.Password-(- -- * Password Hashing- hashPassword-)-where--import Crypto.BCrypt hiding (hashPassword)-import qualified Data.ByteString.Char8 as B (pack,unpack)---- | Hash a password with the most strict 'HashingPolicy'-hashPassword :: String -- ^ Password to hash- -> IO (Maybe String)-hashPassword pwd = do- hsh <- hashPasswordUsingPolicy (HashingPolicy 12 "$2b$") (B.pack pwd)- return $ fmap B.unpack hsh
− example/Main.hs
@@ -1,47 +0,0 @@-{-# 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.1.1+Version: 0.1.2 Synopsis: Haskell web scaffolding using Scotty, WAI, and Warp Homepage: https://github.com/fhsjaagshs/webapp Bug-reports: https://github.com/fhsjaagshs/webapp/issues@@ -24,13 +24,14 @@ Exposed-modules: Web.App Web.App.Assets Web.App.Cookie- Web.App.Daemon Web.App.FileCache Web.App.HTTP- Web.App.Password Web.App.IO Web.App.Monad- other-modules: Web.App.Gzip+ Web.App.Middleware+ Web.App.Middleware.Gzip+ Web.App.Middleware.ForceSSL+ other-modules: Web.App.Daemon Web.App.Privileges Web.App.TerminalSize Web.App.Monad.Internal@@ -64,24 +65,9 @@ hjsmin, css-text, mime-types,- bcrypt, filepath, directory, optparse-applicative- -executable example- default-language: Haskell2010- main-is: Main.hs- hs-source-dirs: example- ghc-options: -threaded -Wall- build-depends: base,- transformers,- text,- bytestring,- scotty,- http-types,- optparse-applicative,- webapp source-repository head type: git