scaleBilinear hangs when the target width is 0

[leeor]

I'm trying to write a simple service that listens for requests to scale PNG images hosted on remote storage. After scaling and re-encoding into PNG format, trying to upload/save the image to the remote storage/local file causes the process to hang with ~99% cpu usage.

Originally, I tried using Network.HTTP.Simple at first, the code below is using savePngImage to make sure it nothing to do with the client (also tried wreq). Uploading a short text string or the original image works well. I also tried initiating the request with either lazy or strict ByteString - but it's all the same.

The upload request is not even starting, but when I save to a file, like the code below, a 0-sized file is created. Pretty new to Haskell, so I'm not really sure how to proceed in figuring out what's causing this issue.

Any pointers on what might help me shed some light on what's going on?

The code below is somewhat minimal, I tinkered with it quite a bit to narrow it down to the actual point of uploading the file, obviously though, non-strictness could mean I'm still wrong about it :-).

TestScale.hs

#!/usr/bin/env stack
-- stack --resolver lts-17.11 script
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}
module Scale where

import           Control.Monad.IO.Class (liftIO)
import           Codec.Picture
import           Codec.Picture.Extra
import qualified Control.Exception      as Exc
import           Data.ByteString        (ByteString)
import qualified Data.ByteString.Lazy   as B
import           Data.String            (IsString)
import           Data.Text
import           Text.Show
import           Text.URI               ()

scaleToHeight :: Int
scaleToHeight = 200

scaleImage :: DynamicImage -> Either String DynamicImage
scaleImage image =
    case image of
                ImageY8 img -> Right $ ImageY8 $ scaleBilinear scaleToWidth scaleToHeight img
                ImageY16 img -> Right $ ImageY16 $ scaleBilinear scaleToWidth scaleToHeight img
                ImageY32 img -> Right $ ImageY32 $ scaleBilinear scaleToWidth scaleToHeight img
                ImageYF img -> Left "cannot scale an HDR image" -- Right $ ImageYF $ scaleBilinear scaleToWidth scaleToHeight img
                ImageYA8 img -> Right $ ImageYA8 $ scaleBilinear scaleToWidth scaleToHeight img
                ImageYA16 img -> Right $ ImageYA16 $ scaleBilinear scaleToWidth scaleToHeight img
                ImageRGB8 img -> Right $ ImageRGB8 $ scaleBilinear scaleToWidth scaleToHeight img
                ImageRGB16 img -> Right $ ImageRGB16 $ scaleBilinear scaleToWidth scaleToHeight img
                ImageRGBF img -> Left "cannot scale an HDR image" -- Right $ ImageRGBF $ scaleBilinear scaleToWidth scaleToHeight img
                ImageRGBA8 img -> Right $ ImageRGBA8 $ scaleBilinear scaleToWidth scaleToHeight img
                ImageRGBA16 img -> Right $ ImageRGBA16 $ scaleBilinear scaleToWidth scaleToHeight img
                ImageYCbCr8 img -> Right $ ImageYCbCr8 $ scaleBilinear scaleToWidth scaleToHeight img
                ImageCMYK8 img -> Right $ ImageCMYK8 $ scaleBilinear scaleToWidth scaleToHeight img
                ImageCMYK16 img -> Right $ ImageCMYK16 $ scaleBilinear scaleToWidth scaleToHeight img
    where
        width = dynamicMap imageWidth image
        height = dynamicMap imageHeight image
        scaleFactor = scaleToHeight `div` height
        scaleToWidth = scaleFactor * scaleFactor

main :: IO ()
main = do
    image <- liftIO $ readImage "./logo.png"

    let scaledImage = image >>= scaleImage
    case scaledImage of
        Left err ->
            putStrLn $ "error: " <> err
        Right scaledImage -> do
            savePngImage "./scaled.png" scaledImage
            putStrLn "done"

project.yaml

name:    test-scaler
version: "0.0.0"

dependencies:
- base
- yesod-core
- http-client
- http-conduit
- modern-uri
- text
- bytestring
- JuicyPixels
- JuicyPixels-extra
- wreq
- lens

# The library contains all of our application code. The executable
# defined below is just a thin wrapper.
library:
  source-dirs: src

# Runnable executable for our application
executables:
  image-scaler:
    main: Main.hs
    source-dirs: app
    ghc-options:
    - -threaded
    - -rtsopts
    - -with-rtsopts=-N
    dependencies:
    - image-scaler

Stack resolver is lts-17.11.

EDIT: clean up the code a bit.
EDIT2: removed all networking code.

[mrkkrp]

Are you sure that this is related to this library? If it is, it should be possible to create an repro example without any networking stuff involved.

[leeor]

You're right. I've update the code above to not use any network, simply read a file named logo.png and write to scaled.png. It behaves the same. Tested with several PNG files.

[leeor]

Hi @mrkkrp, can you please have another look at this? I've removed all networking related code from the repro sample. It's only using local files, and the same issue persists.

[mrkkrp]

It is on my todo list, I'll look at it as soon as I have time.

[mrkkrp]

This hangs because you scale to width 0. After dividing scaleToHeight :: Int by height :: Int you (probably) get 0 :: Int. Try with this:

    where
        width = dynamicMap imageWidth image
        height = dynamicMap imageHeight image
        scaleFactor :: Double
        scaleFactor = fromIntegral scaleToHeight / fromIntegral height
        scaleToWidth = floor (scaleFactor * fromIntegral width)

Probably, there is also a bug in scaleBilinear because it should not hang when either of the dimensions is zero.