diff --git a/Web/App.hs b/Web/App.hs --- a/Web/App.hs +++ b/Web/App.hs @@ -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" diff --git a/Web/App/Daemon.hs b/Web/App/Daemon.hs --- a/Web/App/Daemon.hs +++ b/Web/App/Daemon.hs @@ -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 diff --git a/Web/App/Gzip.hs b/Web/App/Gzip.hs deleted file mode 100644 --- a/Web/App/Gzip.hs +++ /dev/null @@ -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 diff --git a/Web/App/HTTP.hs b/Web/App/HTTP.hs --- a/Web/App/HTTP.hs +++ b/Web/App/HTTP.hs @@ -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 diff --git a/Web/App/Middleware.hs b/Web/App/Middleware.hs new file mode 100644 --- /dev/null +++ b/Web/App/Middleware.hs @@ -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 diff --git a/Web/App/Middleware/ForceSSL.hs b/Web/App/Middleware/ForceSSL.hs new file mode 100644 --- /dev/null +++ b/Web/App/Middleware/ForceSSL.hs @@ -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)] "" diff --git a/Web/App/Middleware/Gzip.hs b/Web/App/Middleware/Gzip.hs new file mode 100644 --- /dev/null +++ b/Web/App/Middleware/Gzip.hs @@ -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 diff --git a/Web/App/Password.hs b/Web/App/Password.hs deleted file mode 100644 --- a/Web/App/Password.hs +++ /dev/null @@ -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 diff --git a/example/Main.hs b/example/Main.hs deleted file mode 100644 --- a/example/Main.hs +++ /dev/null @@ -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 diff --git a/webapp.cabal b/webapp.cabal --- a/webapp.cabal +++ b/webapp.cabal @@ -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