-- | Create image thumbnails -- -- Using the default configuration -- -- >>> createThumbnails defaultConfig [Size 512 512, Size 128 128] "/opt/app/image.jpg" -- -- Or specify a custom 'Configuration' {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Graphics.Thumbnail ( createThumbnails , defaultConfig , imageSize , Thumbnail(..) , Configuration(..) , ImageFileFormat(..) , Rect(..) , Size(..) , ThumbnailException(..) ) where import Control.Exception import qualified Crypto.Nonce as Nonce import Data.Bool (bool) import Data.ByteString (hGetContents) import Data.Char (toLower) import Data.Default (Default (..)) import Data.Maybe (catMaybes) import Data.Text (unpack) import System.Directory (getTemporaryDirectory) import System.FilePath.Posix (()) import System.IO (IOMode (..), hClose, hFileSize, openFile) import Vision.Image (InterpolMethod (NearestNeighbor), RGB, crop, resize, shape) import qualified Vision.Image.Storage.DevIL as Devil (Autodetect (..), BMP (..), JPG (..), PNG (..), SaveImageType, load, save) import qualified Vision.Primitive as P (Rect (..), Size, ix2) import Vision.Primitive.Shape as PS createThumbnails :: Configuration -- ^ Use 'defaultConfig' for default values -> [Size] -- ^ Thumbnail sizes to create -> FilePath -- ^ Input image -> IO [Thumbnail] createThumbnails config@Configuration{..} reqSizes inputFp = do imageResult <- Devil.load Devil.Autodetect inputFp (originalImage :: RGB) <- either (\_ -> throwIO FailedToLoadImage) pure imageResult let image = maybe originalImage (`cropImage` originalImage) cropFirst let imageSize = size image let sizes = bool reqSizes (fitAspectRatio imageSize <$> reqSizes) preserveAspectRatio dstDir <- dstDirectory suffix <- bool (pure "") (('_' :) <$> nonce) nonceSuffix thumbnails <- catMaybes <$> traverse (createThumbnail config suffix dstDir image imageSize) sizes pure thumbnails where cropImage :: Rect -> RGB -> RGB cropImage (Rect x y (Size w h)) = crop (P.Rect x y w h) fitAspectRatio :: Size -> Size -> Size fitAspectRatio (Size iW iH) (Size oW oH) | iW > iH = Size oW $ round $ fromIntegral (oH * iH) / fromIntegral iW | iH > iW = Size (round $ fromIntegral (oW * iW) / fromIntegral iH) oH | otherwise = Size oW oH nonce :: IO String nonce = take 10 . unpack <$> (Nonce.new >>= Nonce.nonce128urlT) createThumbnail :: Configuration -> String -> FilePath -> RGB -> Size -> Size -> IO (Maybe Thumbnail) createThumbnail Configuration{..} suffix dstDir img imgSize size@(Size w h) = do let name = namePrefix <> show w <> "_" <> show h <> suffix <> "." <> (toLower <$> show fileFormat) if size > imgSize && not upScaleOriginal then pure Nothing else Just <$> do let thumbImg = makeThumb size img let filePath = dstDir name -- FIXME: Horrible hack, what to do? case fileFormat of BMP -> Devil.save Devil.BMP filePath thumbImg JPG -> Devil.save Devil.JPG filePath thumbImg PNG -> Devil.save Devil.PNG filePath thumbImg pure $ Thumbnail filePath size where makeThumb :: Size -> RGB -> RGB makeThumb (Size w h) = resize NearestNeighbor (ix2 h w) imageSize :: FilePath -> IO Size imageSize fp = do imgResult <- Devil.load Devil.Autodetect fp img <- either (\_ -> throwIO FailedToLoadImage) pure imgResult pure $ size img size :: RGB -> Size size img = let (Z :. h :. w) = shape img in Size w h data Configuration = Configuration { fileFormat :: ImageFileFormat -- ^ In which file format to encode the created thumbnails. Default: JPG , cropFirst :: Maybe Rect -- ^ Whether the input image should be cropped to 'Rect' before creating -- thumbnails or left intact. The first thumbnail in the list will be -- the cropped input image. Default: Nothing , preserveAspectRatio :: Bool -- ^ Whether the created thumbnails should adhere to only one dimension -- of the requested size in order to preserve the original image aspect -- ratio or distort the image to make it fit. Default: True , upScaleOriginal :: Bool -- ^ Whether the original image should be up scaled to make it fit the -- requested thumbnail sizes when the input image is too small (nearest -- neighbor interpolation), otherwise ignore the requested thumbnails -- that are bigger than the input image. Default: False , namePrefix :: String -- ^ Created thumbnail files are named based on it's size, this option -- adds a prefix (e.g. "512_512.jpg"). Default: "thumbnail-" , nonceSuffix :: Bool -- Whether to end thumbnail file names with a small nonce (i.e. a random -- string of characters). Useful for overwriting images that are prone -- to stay in cache. Default: False , dstDirectory :: IO FilePath -- ^ Where to put the created thumbnails. -- Default: 'getTemporaryDirectory' } data Size = Size { width :: Int , height :: Int } deriving (Show, Read, Eq) instance Ord Size where compare s1@(Size w1 h1) s2@(Size w2 h2) | s1 == s2 = EQ | w1 > w2 || h1 > h2 = GT | otherwise = LT data Rect = Rect { rX :: Int -- ^ X coordinate of the first pixel , rY :: Int -- ^ Y coordinate of the first pixel , rSize :: Size -- ^ Size of the rectangle } deriving (Show, Read, Eq, Ord) data ImageFileFormat = BMP | JPG | PNG deriving (Show, Read, Enum, Eq, Ord) data Thumbnail = Thumbnail { thumbFp :: FilePath , thumbSize :: Size -- ^ Actual size of the created thumbnail. Might differ from the -- requested size if the `preserveAspectRatio` option is used } deriving (Show, Eq) defaultConfig = Configuration { fileFormat = JPG , cropFirst = Nothing , preserveAspectRatio = True , upScaleOriginal = False , namePrefix = "thumbnail-" , nonceSuffix = False , dstDirectory = getTemporaryDirectory } data ThumbnailException = FailedToLoadImage deriving (Show, Eq) instance Exception ThumbnailException