Haskell req multi-part upload, observed

reqMultiPartUpload.hs

import           Control.Exception.Safe (throwString)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text as Txt
import qualified Data.Text.Encoding as TxtE
import qualified Network.HTTP.Client as HC
import qualified Network.HTTP.Client.MultipartFormData as MFD
import           Network.HTTP.Req ((/:))
import qualified Network.HTTP.Req as R
import qualified System.FilePath as Fp
import qualified Text.URI as URI


upload :: Text -> Map Text Text -> FilePath -> Maybe ((Int64, Int64) -> IO ()) -> IO Text
upload url extraOpts path onProgress' = do
  let opts = Map.toList extraOpts <&> \(k, v) -> R.header (TxtE.encodeUtf8 k) (TxtE.encodeUtf8 v)

  rb <-
    case onProgress' of
      Nothing -> HC.RequestBodyLBS <$> BSL.readFile path
      Just onProgress -> HC.observedStreamFile (\s -> onProgress (HC.fileSize s, HC.readSoFar s)) path

  rbp <- R.reqBodyMultipart [ MFD.partFileRequestBody "file" (Fp.takeFileName path) rb ]

  (URI.mkURI url <&> R.useURI) >>= \case
    Nothing -> throwString . Txt.unpack $ "Unable to parse url for file link: " <> uf ^. ufForm . uffUrl
    Just u ->
      case u of
        Right (httpUrl, httpOptions) -> go httpUrl (httpOptions <> mconcat opts) rbp
        Left (httpsUrl, httpsOptions) -> go httpsUrl (httpsOptions <> mconcat opts) rbp

  where
    go :: (R.HttpBody body) => R.Url s -> R.Option s -> body -> IO BSL.ByteString
    go url' options body = do
      R.runReq R.defaultHttpConfig $ do
        r <- R.req R.POST url' body R.lbsResponse options

        pure (R.responseBody r)