webapp 0.3.4 → 0.3.5
raw patch · 4 files changed
+22/−64 lines, 4 files
Files
- Web/App/Middleware.hs +1/−3
- Web/App/Middleware/ForceSSL.hs +0/−33
- Web/App/Middleware/Gzip.hs +20/−26
- webapp.cabal +1/−2
Web/App/Middleware.hs view
@@ -1,9 +1,7 @@ module Web.App.Middleware (- module Web.App.Middleware.Gzip,- module Web.App.Middleware.ForceSSL+ module Web.App.Middleware.Gzip ) where import Web.App.Middleware.Gzip-import Web.App.Middleware.ForceSSL
− Web/App/Middleware/ForceSSL.hs
@@ -1,33 +0,0 @@-{-# 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)---- TODO: specify port--- |Middleware to force SSL traffic.-forceSSL :: Int -> Middleware-forceSSL port 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
@@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} {-|-Module : Web.App.Gzip+Module : Web.App.Middleware.Gzip Copyright : (c) Nathaniel Symer, 2015 License : MIT Maintainer : nate@symer.io@@ -18,42 +18,36 @@ import Network.Wai import Network.Wai.Internal-import Data.Maybe (fromMaybe,isJust)+import Data.Maybe (fromMaybe) import qualified Codec.Compression.GZip as GZIP (compress)-import qualified Data.ByteString.Char8 as B (ByteString,readInteger,isInfixOf,break,drop,dropWhile)+import qualified Data.ByteString.Char8 as B (readInt,isInfixOf) 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+gzip :: Int -- ^ 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+ | isCompressable = sendCompressed 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- contentLength hdrs = lookup "Content-Length" hdrs >>= fmap fst . B.readInteger+ where+ isCompressable = isAccepted && not isIE6 && isBigEnough && not isEncoded+ isAccepted = headerContains "gzip" "Accept-Encoding" $ requestHeaders env+ isIE6 = headerContains "MSIE 6" "User-Agent" $ requestHeaders env+ isEncoded = headerContains "gzip" "Content-Encoding" $ responseHeaders res+ isBigEnough = maybe True ((<=) minLen) contentLength+ contentLength = getResHeader "Content-Length" >>= fmap fst . B.readInt+ getResHeader k = lookup k $ responseHeaders res+ headerContains s k hdrs = fromMaybe False $ B.isInfixOf s <$> lookup k hdrs --- TODO: ensure original flushing action is eval'd-compressResponse :: Response -> (Response -> IO a) -> IO a-compressResponse res sendResponse = f $ lookup "Content-Type" hs+sendCompressed :: Response -> (Response -> IO a) -> IO a+sendCompressed res f = maybe (f res) (const send) $ 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+ invariants = [("Vary","Accept-Encoding"),("Content-Encoding","gzip")]+ hs' = invariants ++ (filter ((/=) "Content-Length" . fst) hs)+ send = wb $ \b -> f $ responseStream s hs' (b . (. compress))+ compress = fromLazyByteString . GZIP.compress . toLazyByteString
webapp.cabal view
@@ -1,5 +1,5 @@ Name: webapp-Version: 0.3.4+Version: 0.3.5 Synopsis: Haskell web app framework based on WAI & Warp Homepage: https://github.com/fhsjaagshs/webapp Bug-reports: https://github.com/fhsjaagshs/webapp/issues@@ -23,7 +23,6 @@ Web.App.State Web.App.Middleware Web.App.Middleware.Gzip- Web.App.Middleware.ForceSSL Web.App.Parameter Web.App.Path Web.App.RouteT