fix: ignore body of responses to head requests as per spec

src/Lib/Prelude.hs

@@ -37,13 +37,14 @@ import UnliftIO as Exports
     throwIO,
     try,
   )
+import qualified Data.Text.Encoding as T
 
 -- | Apply a function on both elements of a pair
 both :: (a -> b) -> (a, a) -> (b, b)
 both f (a, b) = (f a, f b)
 
-showBS :: (Show a) => a -> ByteString
+showBS :: Show a => a -> ByteString
-showBS a = encodeUtf8 (show a :: Text)
+showBS a = T.encodeUtf8 (show a :: Text)
 
 toStrictBS :: LByteString -> ByteString
 toStrictBS = LB.toStrict

src/Network/Minio.hs

@@ -41,13 +41,14 @@ module Network.Minio
     findFirst,
 
     -- * Connecting to object storage
-    ConnectInfo,
+    ConnectInfo(..),
     setRegion,
     setCreds,
     setCredsFrom,
     isConnectInfoSecure,
     disableTLSCertValidation,
     MinioConn,
+    connect,
     mkMinioConn,
 
     -- ** Connection helpers

src/Network/Minio/Data.hs

@@ -1068,7 +1068,7 @@ defaultS3ReqInfo =
 
 getS3Path :: Maybe Bucket -> Maybe Object -> ByteString
 getS3Path b o =
-  let segments = map encodeUtf8 $ catMaybes $ b : bool [] [o] (isJust b)
+  let segments = map TE.encodeUtf8 $ catMaybes $ b : bool [] [o] (isJust b)
    in B.concat ["/", B.intercalate "/" segments]
 
 type RegionMap = H.HashMap Bucket Region
@@ -1084,10 +1084,12 @@ newtype Minio a = Minio
       Monad,
       MonadIO,
       MonadReader MinioConn,
-      MonadResource,
+      MonadResource
-      MonadUnliftIO
     )
 
+instance MonadUnliftIO Minio where
+  withRunInIO inner = Minio $ U.askUnliftIO >>= \(U.UnliftIO unliftIO) -> liftIO (inner $ \(Minio f) -> unliftIO f)
+
 -- | MinioConn holds connection info and a connection pool to allow
 -- for efficient resource re-use.
 data MinioConn = MinioConn

src/Network/Minio/PresignedOperations.hs

@@ -41,6 +41,7 @@ import qualified Data.Aeson as Json
 import Data.ByteString.Builder (byteString, toLazyByteString)
 import qualified Data.HashMap.Strict as H
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
 import qualified Data.Time as Time
 import Lib.Prelude
 import qualified Network.HTTP.Client as NClient
@@ -334,7 +335,7 @@ presignedPostPolicy p = do
       mkPair (PPCEquals k v) = Just (k, v)
       mkPair _ = Nothing
       formFromPolicy =
-        H.map encodeUtf8 $
+        H.map TE.encodeUtf8 $
           H.fromList $
             mapMaybe
               mkPair

src/Network/Minio/S3API.hs

@@ -109,6 +109,7 @@ where
 
 import qualified Data.ByteString as BS
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
 import Lib.Prelude
 import qualified Network.HTTP.Conduit as NC
 import qualified Network.HTTP.Types as HT
@@ -389,7 +390,7 @@ putObjectPart bucket object uploadId partNumber headers payload = do
 srcInfoToHeaders :: SourceInfo -> [HT.Header]
 srcInfoToHeaders srcInfo =
   ( "x-amz-copy-source",
-    encodeUtf8 $
+    TE.encodeUtf8 $
       T.concat
         [ "/",
           srcBucket srcInfo,

src/Network/Minio/Sign/V4.hs

@@ -49,6 +49,8 @@ import Network.Minio.Data.Crypto
 import Network.Minio.Data.Time
 import Network.Minio.Errors
 import Text.Printf (printf)
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text as T
 
 -- these headers are not included in the string to sign when signing a
 -- request
@@ -86,7 +88,7 @@ mkAuthHeader accessKey scope signedHeaderKeys sign =
   let authValue =
         B.concat
           [ "AWS4-HMAC-SHA256 Credential=",
-            encodeUtf8 accessKey,
+            TE.encodeUtf8 accessKey,
             "/",
             scope,
             ", SignedHeaders=",
@@ -317,7 +319,7 @@ getSigningKey :: SignParams -> ByteString
 getSigningKey sp =
   hmacSHA256RawBS "aws4_request"
     . hmacSHA256RawBS (toByteString $ spService sp)
-    . hmacSHA256RawBS (encodeUtf8 $ fromMaybe "" $ spRegion sp)
+    . hmacSHA256RawBS (TE.encodeUtf8 $ fromMaybe "" $ spRegion sp)
     . hmacSHA256RawBS (awsDateFormatBS $ spTimeStamp sp)
     $ B.concat ["AWS4", BA.convert $ spSecretKey sp]
 

src/Network/Minio/Utils.hs

@@ -184,10 +184,10 @@ httpLbs req mgr = do
   resp <- either throwIO return respE
   unless (isSuccessStatus $ NC.responseStatus resp) $
     case contentTypeMay resp of
-      Just "application/xml" -> do
+      Just "application/xml" | expectBody -> do
         sErr <- parseErrResponse $ NC.responseBody resp
         throwIO sErr
-      Just "application/json" -> do
+      Just "application/json" | expectBody -> do
         sErr <- parseErrResponseJSON $ NC.responseBody resp
         throwIO sErr
       _ ->
@@ -204,6 +204,7 @@ httpLbs req mgr = do
     contentTypeMay resp =
       lookupHeader Hdr.hContentType $
         NC.responseHeaders resp
+    expectBody = NC.method req /= HT.methodHead
 
 http ::
   (MonadUnliftIO m, R.MonadResource m) =>
@@ -215,7 +216,7 @@ http req mgr = do
   resp <- either throwIO return respE
   unless (isSuccessStatus $ NC.responseStatus resp) $
     case contentTypeMay resp of
-      Just "application/xml" -> do
+      Just "application/xml" | expectBody -> do
         respBody <- C.connect (NC.responseBody resp) CB.sinkLbs
         sErr <- parseErrResponse respBody
         throwIO sErr
@@ -235,6 +236,7 @@ http req mgr = do
     contentTypeMay resp =
       lookupHeader Hdr.hContentType $
         NC.responseHeaders resp
+    expectBody = NC.method req /= HT.methodHead
 
 -- Similar to mapConcurrently but limits the number of threads that
 -- can run using a quantity semaphore.