Merge pull request #959 from Vlix/getting-rid-of-warnings-and-hlint-s…

…uggestions

Getting rid of warnings and hlint suggestions

recv/Network/Socket/BufferPool/Buffer.hs

@@ -6,11 +6,12 @@ module Network.Socket.BufferPool.Buffer (
   ) where
 
 import qualified Data.ByteString as BS
-import Data.ByteString.Internal (ByteString(..), memcpy)
+import Data.ByteString.Internal (ByteString(..))
 import Data.ByteString.Unsafe (unsafeTake, unsafeDrop)
 import Data.IORef (newIORef, readIORef, writeIORef)
 import Foreign.ForeignPtr
 import Foreign.Marshal.Alloc (mallocBytes, finalizerFree)
+import Foreign.Marshal.Utils (copyBytes)
 import Foreign.Ptr (castPtr, plusPtr)
 
 import Network.Socket.BufferPool.Types
@@ -59,6 +60,6 @@ mallocBS size = do
 --   This function returns the point where the next copy should start.
 copy :: Buffer -> ByteString -> IO Buffer
 copy ptr (PS fp o l) = withForeignPtr fp $ \p -> do
-    memcpy ptr (p `plusPtr` o) (fromIntegral l)
+    copyBytes ptr (p `plusPtr` o) (fromIntegral l)
     return $ ptr `plusPtr` l
 {-# INLINE copy #-}

wai-extra/ChangeLog.md

@@ -1,5 +1,9 @@
 # Changelog for wai-extra
 
+## 3.1.14.0
+
+* `defaultGzipSettings` now exported to not depend on `Data.Default` [#959](https://github.com/yesodweb/wai/pull/959)
+
 ## 3.1.13.0
 
 * Added `Combine Headers` `Middleware` [#901](https://github.com/yesodweb/wai/pull/901)

wai-extra/Network/Wai/EventSource.hs

@@ -59,3 +59,4 @@ eventStreamAppRaw handler _ sendResponse =
             case eventToBuilder event of
                 Nothing -> return ()
                 Just b  -> sendChunk b
+{- HLint ignore eventStreamAppRaw "Use forM_" -}

wai-extra/Network/Wai/EventSource/EventStream.hs

@@ -66,7 +66,7 @@ field l b = l `mappend` b `mappend` nl
 eventToBuilder :: ServerEvent -> Maybe Builder
 eventToBuilder (CommentEvent txt) = Just $ field commentField txt
 eventToBuilder (RetryEvent   n)   = Just $ field retryField (string8 . show $ n)
-eventToBuilder (CloseEvent)       = Nothing
+eventToBuilder CloseEvent         = Nothing
 eventToBuilder (ServerEvent n i d)= Just $
     name n (evid i $ mconcat (map (field dataField) d)) `mappend` nl
   where

wai-extra/Network/Wai/Handler/CGI.hs

@@ -89,8 +89,7 @@ runGeneric vars inputH outputH xsendfile app = do
         remoteHost' =
             case lookup "REMOTE_ADDR" vars of
                 Just x -> x
-                Nothing ->
-                    fromMaybe "" $ lookup "REMOTE_HOST" vars
+                Nothing -> lookup' "REMOTE_HOST" vars
         isSecure' =
             case map toLower $ lookup' "SERVER_PROTOCOL" vars of
                 "https" -> True
@@ -102,21 +101,21 @@ runGeneric vars inputH outputH xsendfile app = do
                 a:_ -> addrAddress a
                 [] -> error $ "Invalid REMOTE_ADDR or REMOTE_HOST: " ++ remoteHost'
         reqHeaders = map (cleanupVarName *** B.pack) vars
-        env = Request
-            { requestMethod = rmethod
-            , rawPathInfo = B.pack pinfo
-            , pathInfo = H.decodePathSegments $ B.pack pinfo
-            , rawQueryString = B.pack qstring
-            , queryString = H.parseQuery $ B.pack qstring
-            , requestHeaders = reqHeaders
-            , isSecure = isSecure'
-            , remoteHost = addr
-            , httpVersion = H.http11 -- FIXME
-            , requestBody = requestBody'
-            , vault = mempty
-            , requestBodyLength = KnownLength $ fromIntegral contentLength
-            , requestHeaderHost = lookup "host" reqHeaders
-            , requestHeaderRange = lookup hRange reqHeaders
+        env =
+            setRequestBodyChunks requestBody' $ defaultRequest
+                { requestMethod = rmethod
+                , rawPathInfo = B.pack pinfo
+                , pathInfo = H.decodePathSegments $ B.pack pinfo
+                , rawQueryString = B.pack qstring
+                , queryString = H.parseQuery $ B.pack qstring
+                , requestHeaders = reqHeaders
+                , isSecure = isSecure'
+                , remoteHost = addr
+                , httpVersion = H.http11 -- FIXME
+                , vault = mempty
+                , requestBodyLength = KnownLength $ fromIntegral contentLength
+                , requestHeaderHost = lookup "host" reqHeaders
+                , requestHeaderRange = lookup hRange reqHeaders
 #if MIN_VERSION_wai(3,2,0)
             , requestHeaderReferer = lookup "referer" reqHeaders
             , requestHeaderUserAgent = lookup "user-agent" reqHeaders

wai-extra/Network/Wai/Handler/SCGI.hs

@@ -11,6 +11,7 @@ import qualified Data.ByteString.Char8 as S8
 import Data.ByteString.Lazy.Internal (defaultChunkSize)
 import qualified Data.ByteString.Unsafe as S
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import Data.Maybe (fromMaybe, listToMaybe)
 import Foreign.C (CChar, CInt (..))
 import Foreign.Marshal.Alloc (free, mallocBytes)
 import Foreign.Ptr (Ptr, castPtr, nullPtr)
@@ -27,10 +28,12 @@ runOne :: Maybe ByteString -> Application -> IO ()
 runOne sf app = do
     socket <- c'accept 0 nullPtr nullPtr
     headersBS <- readNetstring socket
-    let headers@((_, conLenS):_) = parseHeaders $ S.split 0 headersBS
-    let conLen = case reads conLenS of
-                    (i, _):_ -> i
-                    [] -> 0
+    let headers = parseHeaders $ S.split 0 headersBS
+    let conLen =
+            fromMaybe 0 $ do
+                (_, conLenS) <- listToMaybe headers
+                (i, _) <- listToMaybe $ reads conLenS
+                pure i
     conLenI <- newIORef conLen
     runGeneric headers (requestBodyFunc $ input socket conLenI)
               (write socket) sf app
@@ -73,10 +76,10 @@ readNetstring socket = do
   where
     readLen l = do
         bs <- readByteString socket 1
-        let [c] = S8.unpack bs
-        if c == ':'
-            then return l
-            else readLen $ l * 10 + (fromEnum c - fromEnum '0')
+        case S8.unpack bs of
+            [':'] -> return l
+            [c] -> readLen $ l * 10 + (fromEnum c - fromEnum '0')
+            _ -> error "Network.Wai.Handler.SCGI.readNetstring: should never happen"
 
 readByteString :: CInt -> Int -> IO S.ByteString
 readByteString socket len = do

wai-extra/Network/Wai/Middleware/Gzip.hs

@@ -22,6 +22,7 @@ module Network.Wai.Middleware.Gzip
       -- ** The Settings
       -- $settings
     , GzipSettings
+    , defaultGzipSettings
     , gzipFiles
     , gzipCheckMime
     , gzipSizeThreshold
@@ -42,6 +43,7 @@ import Data.ByteString.Builder (byteString)
 import qualified Data.ByteString.Builder.Extra as Blaze (flush)
 import qualified Data.ByteString.Char8 as S8
 import Data.ByteString.Lazy.Internal (defaultChunkSize)
+import Data.Char (isAsciiLower, isAsciiUpper, isDigit)
 import Data.Default.Class (Default (..))
 import Data.Function (fix)
 import Data.Maybe (isJust)
@@ -123,7 +125,7 @@ import Network.Wai.Util (splitCommas, trimWS)
 -- @
 -- myGzipSettings :: 'GzipSettings'
 -- myGzipSettings =
---   'def'
+--   'defaultGzipSettings'
 --     { 'gzipFiles' = 'GzipCompress'
 --     , 'gzipCheckMime' = myMimeCheckFunction
 --     , 'gzipSizeThreshold' = 860
@@ -196,7 +198,17 @@ data GzipFiles
 -- | Use default MIME settings; /do not/ compress files; skip
 -- compression on data smaller than 860 bytes.
 instance Default GzipSettings where
-    def = GzipSettings GzipIgnore defaultCheckMime minimumLength
+    def = defaultGzipSettings
+
+-- | Default settings for the 'gzip' middleware.
+--
+-- * Does not compress files.
+-- * Uses 'defaultCheckMime'.
+-- * Compession threshold set to 860 bytes.
+--
+-- @since 3.1.14.0
+defaultGzipSettings :: GzipSettings
+defaultGzipSettings = GzipSettings GzipIgnore defaultCheckMime minimumLength
 
 -- | MIME types that will be compressed by default:
 -- @text/@ @*@, @application/json@, @application/javascript@,
@@ -348,9 +360,7 @@ compressFile s hs file mETag cache sendResponse = do
     tmpfile = cache ++ '/' : map safe file ++ eTag
 
     safe c
-        | 'A' <= c && c <= 'Z' = c
-        | 'a' <= c && c <= 'z' = c
-        | '0' <= c && c <= '9' = c
+        | isAsciiUpper c || isAsciiLower c || isDigit c = c
     safe '-' = '-'
     safe '_' = '_'
     safe _ = '_'

wai-extra/Network/Wai/Middleware/HttpAuth.hs

@@ -43,7 +43,7 @@ type CheckCreds = ByteString
 basicAuth :: CheckCreds
           -> AuthSettings
           -> Middleware
-basicAuth checkCreds = basicAuth' (\_ -> checkCreds)
+basicAuth = basicAuth' . const
 
 -- | Like 'basicAuth', but also passes a request to the authentication function.
 --
@@ -120,7 +120,7 @@ extractBasicAuth bs =
     extract encoded =
         let raw = decodeLenient encoded
             (username, password') = S.break (== _colon) raw
-        in ((username,) . snd) <$> S.uncons password'
+        in (username,) . snd <$> S.uncons password'
 
 -- | Extract bearer authentication data from __Authorization__ header
 -- value. Returns bearer token

wai-extra/Network/Wai/Middleware/MethodOverridePost.hs

@@ -38,6 +38,8 @@ setPost req = do
   body <- (mconcat . toChunks) `fmap` lazyRequestBody req
   ref <- newIORef body
   let rb = atomicModifyIORef ref $ \bs -> (mempty, bs)
+      req' = setRequestBodyChunks rb req
   case parseQuery body of
-    (("_method", Just newmethod):_) -> return $ req {requestBody = rb, requestMethod = newmethod}
-    _                               -> return $ req {requestBody = rb}
+    (("_method", Just newmethod):_) -> return req' {requestMethod = newmethod}
+    _                               -> return req'
+{- HLint ignore setPost "Use tuple-section" -}

wai-extra/Network/Wai/Middleware/RealIp.hs

@@ -48,7 +48,7 @@ realIpHeader header =
 --
 -- @since 3.1.5
 realIpTrusted :: HeaderName -> (IP.IP -> Bool) -> Middleware
-realIpTrusted header isTrusted app req respond = app req' respond
+realIpTrusted header isTrusted app req = app req'
   where
     req' = fromMaybe req $ do
              (ip, port) <- IP.fromSockAddr (remoteHost req)
@@ -90,5 +90,5 @@ findRealIp reqHeaders header isTrusted =
   where
     -- account for repeated headers
     headerVals = [ v | (k, v) <- reqHeaders, k == header ]
-    ips = mapMaybe (readMaybe . B8.unpack) $ concatMap (B8.split ',') headerVals
+    ips = concatMap (mapMaybe (readMaybe . B8.unpack) . B8.split ',') headerVals
     nonTrusted = filter (not . isTrusted) ips

wai-extra/Network/Wai/Middleware/RequestLogger.hs

@@ -50,7 +50,7 @@ import Network.Wai
   ( Request(..), requestBodyLength, RequestBodyLength(..)
   , Middleware
   , Response, responseStatus, responseHeaders
-  , getRequestBodyChunk
+  , getRequestBodyChunk, setRequestBodyChunks
   )
 import Network.Wai.Internal (Response (..))
 import Network.Wai.Logger
@@ -98,7 +98,7 @@ defaultApacheSettings :: ApacheSettings
 defaultApacheSettings = ApacheSettings
     { apacheIPAddrSource = FromSocket
     , apacheRequestFilter = \_ _ -> True
-    , apacheUserGetter = \_ -> Nothing
+    , apacheUserGetter = const Nothing
     }
 
 -- | Where to take IP addresses for clients from. See 'IPAddrSource' for more information.
@@ -400,8 +400,9 @@ getRequestBody req = do
          case chunks of
              [] -> ([], S8.empty)
              x:y -> (y, x)
-  let req' = req { requestBody = rbody }
+  let req' = setRequestBodyChunks rbody req
   return (req', body)
+{- HLint ignore getRequestBody "Use lambda-case" -}
 
 detailedMiddleware' :: Callback
                     -> DetailedSettings
@@ -502,6 +503,7 @@ detailedMiddleware' cb DetailedSettings{..} ansiColor ansiMethod ansiStatusCode
         <> " "
         <> toLogStr (pack $ show $ diffUTCTime t1 t0)
         <> "\n"
+{- HLint ignore detailedMiddleware' "Use lambda-case" -}
 
 statusBS :: Response -> BS.ByteString
 statusBS = pack . show . statusCode . responseStatus

wai-extra/Network/Wai/Middleware/Routed.hs

@@ -35,5 +35,4 @@ hostedMiddleware domain middle app req
   | otherwise            = app req
 
 hasDomain :: ByteString -> Request -> Bool
-hasDomain domain req = maybe False (== domain) mHost
-  where mHost = requestHeaderHost req
+hasDomain domain req = Just domain == requestHeaderHost req

wai-extra/Network/Wai/Middleware/StreamFile.hs

@@ -32,6 +32,6 @@ streamFile app env sendResponse = app env $ \res ->
             sendBody :: StreamingBody -> IO ResponseReceived
             sendBody body = do
                len <- getFileSize fp
-               let hs' = (hContentLength, (S8.pack (show len))) : hs
+               let hs' = (hContentLength, S8.pack (show len)) : hs
                sendResponse $ responseStream s hs' body
       _ -> sendResponse res

wai-extra/Network/Wai/Parse.hs

@@ -58,6 +58,7 @@ import Control.Exception (catchJust)
 import qualified Control.Exception as E
 import Control.Monad (guard, unless, when)
 import Control.Monad.Trans.Resource (InternalState, allocate, register, release, runInternalState)
+import Data.Bifunctor (bimap)
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Char8 as S8
 import qualified Data.ByteString.Lazy as L
@@ -377,7 +378,7 @@ parseRequestBodyEx :: ParseRequestBodyOptions
 parseRequestBodyEx o s r =
     case getRequestBodyType r of
         Nothing -> return ([], [])
-        Just rbt -> sinkRequestBodyEx o s rbt (requestBody r)
+        Just rbt -> sinkRequestBodyEx o s rbt (getRequestBodyChunk r)
 
 sinkRequestBody :: BackEnd y
                 -> RequestBodyType
@@ -400,7 +401,7 @@ sinkRequestBodyEx o s r body = do
                 Left y'  -> ((y':y, z), ())
                 Right z' -> ((y, z':z), ())
     conduitRequestBodyEx o s r body add
-    (\(a, b) -> (reverse a, reverse b)) <$> readIORef ref
+    bimap reverse reverse <$> readIORef ref
 
 conduitRequestBodyEx :: ParseRequestBodyOptions
                      -> BackEnd y
@@ -496,6 +497,7 @@ readSource (Source f ref) = do
     if S.null bs
         then f
         else return bs
+{- HLint ignore readSource "Use tuple-section" -}
 
 leftover :: Source -> S.ByteString -> IO ()
 leftover (Source _ ref) = writeIORef ref

wai-extra/Network/Wai/Request.hs

@@ -83,18 +83,17 @@ requestSizeCheck maxSize req =
     case requestBodyLength req of
         KnownLength len  ->
             if len > maxSize
-                then return $ req { requestBody = throwIO (RequestSizeException maxSize) }
+                then return $ setRequestBodyChunks (throwIO $ RequestSizeException maxSize) req
                 else return req
         ChunkedBody      -> do
             currentSize <- newIORef 0
-            return $ req
-                { requestBody = do
-                    bs <- requestBody req
+            let rbody = do
+                    bs <- getRequestBodyChunk req
                     total <-
                         atomicModifyIORef' currentSize $ \sz ->
                             let nextSize = sz + fromIntegral (S.length bs)
                             in (nextSize, nextSize)
                     if total > maxSize
                     then throwIO (RequestSizeException maxSize)
                     else return bs
-                }
+            return $ setRequestBodyChunks rbody req

wai-extra/Network/Wai/Test.hs

@@ -138,7 +138,7 @@ setRawPathInfo r rawPinfo =
     let pInfo = dropFrontSlash $ T.split (== '/') $ TE.decodeUtf8 rawPinfo
     in  r { rawPathInfo = rawPinfo, pathInfo = pInfo }
   where
-    dropFrontSlash ("":"":[]) = [] -- homepage, a single slash
+    dropFrontSlash ["",""] = [] -- homepage, a single slash
     dropFrontSlash ("":path) = path
     dropFrontSlash path = path
 
@@ -184,13 +184,12 @@ extractSetCookieFromSResponse response = do
 srequest :: SRequest -> Session SResponse
 srequest (SRequest req bod) = do
     refChunks <- liftIO $ newIORef $ L.toChunks bod
-    request $
-      req
-        { requestBody = atomicModifyIORef refChunks $ \bss ->
+    let rbody = atomicModifyIORef refChunks $ \bss ->
             case bss of
                 [] -> ([], S.empty)
                 x:y -> (y, x)
-        }
+    request $ setRequestBodyChunks rbody req
+{- HLint ignore srequest "Use lambda-case" -}
 
 runResponse :: IORef SResponse -> Response -> IO ResponseReceived
 runResponse ref res = do

wai-extra/Network/Wai/UrlMap.hs

@@ -38,7 +38,7 @@ type Path = [Text]
 newtype UrlMap' a = UrlMap' { unUrlMap :: [(Path, a)] }
 
 instance Functor UrlMap' where
-    fmap f (UrlMap' xs) = UrlMap' (fmap (\(p, a) -> (p, f a)) xs)
+    fmap f (UrlMap' xs) = UrlMap' (fmap (fmap f) xs)
 
 instance Applicative UrlMap' where
     pure x                        = UrlMap' [([], x)]
@@ -61,7 +61,7 @@ mount' prefix thing = UrlMap' [(prefix, toApplication thing)]
 -- | A convenience function like mount', but for mounting things under a single
 -- path segment.
 mount :: ToApplication a => Text -> a -> UrlMap
-mount prefix thing = mount' [prefix] thing
+mount prefix = mount' [prefix]
 
 -- | Mount something at the root. Use this for the last application in the
 -- block, to avoid 500 errors from none of the applications matching.
@@ -72,7 +72,7 @@ try :: Eq a
     => [a] -- ^ Path info of request
     -> [([a], b)] -- ^ List of applications to match
     -> Maybe ([a], b)
-try xs tuples = foldl go Nothing tuples
+try xs = foldl go Nothing
     where
         go (Just x) _ = Just x
         go _ (prefix, y) = stripPrefix prefix xs >>= \xs' -> return (xs', y)