diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2014, Prowdsponsor +Copyright (c) 2011, Michael Snoyman + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Felipe Lessa nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +thumbnail-plus +============== + +Generate thumbnails easily and safely. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Graphics/ThumbnailPlus.hs b/src/Graphics/ThumbnailPlus.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/ThumbnailPlus.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE DeriveDataTypeable, + RecordWildCards #-} +module Graphics.ThumbnailPlus + ( createThumbnails + , Configuration(..) + , Size(..) + , ReencodeOriginal(..) + , FileFormat(..) + , CreatedThumbnails(..) + , Thumbnail(..) + , NoShow(..) + ) where + +import Control.Arrow ((***)) +import Control.Monad (unless) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Either (runEitherT, left, right) +import Data.Default (Default(..)) +import Data.Maybe (fromMaybe) +import qualified Control.Exception as E +import qualified Control.Monad.Trans.Resource as R +import qualified Data.Conduit as C +import qualified Data.Conduit.Binary as CB +import qualified Data.Typeable as T +import qualified Graphics.GD as GD +import qualified System.Directory as D +import qualified System.IO as IO +import qualified System.IO.Temp as T + +import Graphics.ThumbnailPlus.ImageSize + + +-- | Configuration used when +data Configuration = + Configuration + { maxFileSize :: !Integer + -- ^ Maximum file size in bytes. Files larger than this + -- limit are rejected. Default: 5 MiB. + , maxImageSize :: !Size + -- ^ Maximum image size in pixels. Images which exceed this + -- limit in any dimension are rejected. Default: 3000x3000px. + , reencodeOriginal :: !ReencodeOriginal + -- ^ Whether the original image should be reencoded. + -- Default: 'SameFileFormat'. + , thumbnailSizes :: [(Size, Maybe FileFormat)] + -- ^ The sizes of the thumbnails that should be created. + -- Thumbnails preserve the aspect ratio and have at least + -- one dimension equal to the given requested size. Sizes + -- larger than the original image will be disregarded. If a + -- 'FileFormat' is not provided, the same file format as + -- the original image is reused. Default: 512x512, 64x64. + , temporaryDirectory :: IO FilePath + -- ^ Temporary directory where files should be + -- saved. Default: 'D.getTemporaryDirectory'. + } deriving (T.Typeable) + +instance Default Configuration where + def = Configuration + { maxFileSize = 2 * 1024 * 1024 + , maxImageSize = Size 4096 4096 + , reencodeOriginal = SameFileFormat + , thumbnailSizes = [(Size 512 512, Nothing), (Size 64 64, Nothing)] + , temporaryDirectory = D.getTemporaryDirectory + } + +-- | Whether the original image should be reencoded or not (cf., +-- 'reencodeOriginal'). +data ReencodeOriginal = + Never + -- ^ Do not reencode the original image. + | SameFileFormat + -- ^ Reencode the original using the same file format. + | NewFileFormat !FileFormat + -- ^ Reencode the original using the given file format. + deriving (Eq, Ord, Show, T.Typeable) + + +-- | cf. 'thumbnailSizes'. +calculateThumbnailSize + :: Size -- ^ Original size. + -> Size -- ^ Thumbnail max size. + -> Size -- ^ Calculated thumbnail size. +calculateThumbnailSize (Size ow oh) (Size tw th) = + let -- Assuming final height is th. + wByH = ow * th `div` oh + -- Assuming final width is tw. + hByW = oh * tw `div` ow + in if wByH > tw + then Size tw hByW + else Size wByH th + + +-- | Process an image and generate thumbnails for it according to +-- the given 'Configuration'. +createThumbnails + :: R.MonadResource m + => Configuration -- ^ Configuration values (use 'def' for default values). + -> FilePath -- ^ Input image file path. + -> m CreatedThumbnails +createThumbnails conf inputFp = do + checkRet <- liftIO (checkInput conf inputFp) + case checkRet of + Left ret -> return ret + Right (size, ff) -> doCreateThumbnails conf (inputFp, size, ff) + +checkInput :: Configuration -> FilePath -> IO (Either CreatedThumbnails (Size, FileFormat)) +checkInput Configuration {..} inputFp = + -- No resources from the input check are needed to create the + -- thumbnails, use an inner ResourceT. + R.runResourceT $ runEitherT $ do + (_, inputH) <- lift $ R.allocate (IO.openFile inputFp IO.ReadMode) IO.hClose + fileSize <- liftIO $ IO.hFileSize inputH + unless (fileSize <= maxFileSize) $ left (FileSizeTooLarge fileSize) + minfo <- CB.sourceHandle inputH C.$$ sinkImageInfo + info@(imageSize, _) <- maybe (left ImageFormatUnrecognized) right minfo + unless (imageSize `fits` maxImageSize) $ left (ImageSizeTooLarge imageSize) + return info + +fits :: Size -> Size -> Bool +Size aw ah `fits` Size bw bh = aw <= bw && ah <= bh + +doCreateThumbnails + :: R.MonadResource m + => Configuration + -> (FilePath, Size, FileFormat) + -> m CreatedThumbnails +doCreateThumbnails Configuration {..} (inputFp, inputSize, inputFf) = do + parentDir <- liftIO temporaryDirectory + (relTmpDir, tmpDir) <- + R.allocate + (T.createTempDirectory parentDir "thumbnail-plus-") + (ignoringIOErrors . D.removeDirectoryRecursive) + (relImg, img) <- + R.allocate + (($ inputFp) $ case inputFf of + GIF -> GD.loadGifFile + JPG -> GD.loadJpegFile + PNG -> GD.loadPngFile) + gdFreeImage + let finalThumbSizes = + (case reencodeOriginal of + Never -> id + SameFileFormat -> (:) (inputSize, inputFf) + NewFileFormat ff -> (:) (inputSize, ff)) $ + map (calculateThumbnailSize inputSize *** fromMaybe inputFf) $ + filter (not . (inputSize `fits`) . fst) $ + thumbnailSizes + thumbnails <- mapM (createThumbnail tmpDir img) finalThumbSizes + R.release relImg + return (CreatedThumbnails thumbnails (NoShow relTmpDir)) + +createThumbnail + :: R.MonadResource m + => FilePath + -> GD.Image + -> (Size, FileFormat) + -> m Thumbnail +createThumbnail tmpDir inputImg (size@(Size w h), ff) = do + let template = "thumb-" ++ show w ++ "x" ++ show h ++ "-" + (relTmpFile, (tmpFp, tmpHandle)) <- + R.allocate + (T.openBinaryTempFile tmpDir template) + (\(tmpFile, tmpHandle) -> + ignoringIOErrors $ do + IO.hClose tmpHandle + D.removeFile tmpFile) + liftIO $ do + -- The @gd@ library does not support 'Handle's :'(, close it as + -- early as possible. We don't close it above on the + -- 'R.allocate' because of async exceptions, but it doesn't + -- matter since hClose-ing twice is harmless. + IO.hClose tmpHandle + GD.withImage (GD.resizeImage w h inputImg) $ \resizedImg -> + (\f -> f tmpFp resizedImg) $ + case ff of + GIF -> GD.saveGifFile + JPG -> GD.saveJpegFile (-1) -- TODO: Configurable JPEG quality. + PNG -> GD.savePngFile + return Thumbnail { thumbFp = tmpFp + , thumbSize = size + , thumbFormat = ff + , thumbReleaseKey = NoShow relTmpFile + } + +-- | For some reason, the @gd@ library does not export +-- 'GD.freeImage'. Argh! +gdFreeImage :: GD.Image -> IO () +gdFreeImage img = GD.withImage (return img) (const $ return ()) + +-- | Shamelessly copied and adapted from @temporary@ package. +ignoringIOErrors :: IO () -> IO () +ignoringIOErrors ioe = ioe `E.catch` (\e -> const (return ()) (e :: IOError)) + + +-- | Return value of 'createThumbnails'. +data CreatedThumbnails = + FileSizeTooLarge !Integer + -- ^ File size exceeded 'maxFileSize'. + | ImageSizeTooLarge !Size + -- ^ Image size exceeded 'maxImageSize'. + | ImageFormatUnrecognized + -- ^ Could not parse size information for the image. + -- Remember that we understand JPGs, PNGs and GIFs only. + | CreatedThumbnails ![Thumbnail] !(NoShow R.ReleaseKey) + -- ^ Thumbnails were created successfully. If + -- 'reencodeOriginal' was not 'Never', then the first item of + -- the list is going to be the reencoded image. + deriving (Eq, Show, T.Typeable) + + +-- | Information about a generated thumbnail. Note that if ask +-- for the original image to be reencoded, then the first +-- 'Thumbnail' will actually have the size of the original image. +data Thumbnail = + Thumbnail + { thumbFp :: !FilePath + -- ^ The 'FilePath' where this thumbnail is stored. + , thumbSize :: !Size + -- ^ Size of the thumbnail. + , thumbFormat :: !FileFormat + , thumbReleaseKey :: !(NoShow R.ReleaseKey) + -- ^ Release key that may be used to clean up any resources + -- used by this thumbnail as soon as possible (i.e., before + -- 'R.runResourceT' finishes). + } deriving (Eq, Show, T.Typeable) + + +-- | Hack to allow me to derive 'Show' for data types with fields +-- that don't have 'Show' instances. +newtype NoShow a = NoShow a + +instance T.Typeable a => Show (NoShow a) where + showsPrec _ ~(NoShow a) = + ('<':) . T.showsTypeRep (T.typeOf a) . ('>':) + +instance Eq (NoShow a) where + _ == _ = True diff --git a/src/Graphics/ThumbnailPlus/ImageSize.hs b/src/Graphics/ThumbnailPlus/ImageSize.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/ThumbnailPlus/ImageSize.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveDataTypeable #-} +-- | Detect the image size without opening the image itself. +-- +-- Amazingly, reimplementing this wheel is the recommended way of +-- not processing huge images according to gd's FAQ. We hope to +-- be at least as restrictive as gd itself is, otherwise some +-- malicious image could get past this code and blow on gd's +-- hand. +-- +-- This code has been ressurected by the now-deprecated +-- @imagesize-conduit@ library by Michael Snoyman. +module Graphics.ThumbnailPlus.ImageSize + ( Size (..) + , FileFormat (..) + , sinkImageInfo + ) where + +import qualified Data.ByteString.Lazy as L +import Data.Conduit +import qualified Data.Conduit.Binary as CB +import qualified Data.ByteString as S +import Data.ByteString.Char8 () +import Data.ByteString.Lazy.Char8 () +import qualified Data.Typeable as T +import Control.Applicative ((<$>), (<*>)) + + +data Size = Size { width :: Int, height :: Int } + deriving (Show, Eq, Ord, Read, T.Typeable) + + +data FileFormat = GIF | PNG | JPG + deriving (Show, Eq, Ord, Read, Enum, T.Typeable) + + +-- | Find out the size of an image. Also returns the file format +-- that parsed correctly. Note that this function does not +-- verify that the file is indeed in the format that it returns, +-- since it looks only at a small part of the header. +sinkImageInfo :: Monad m => Consumer S.ByteString m (Maybe (Size, FileFormat)) +sinkImageInfo = start id + where + start front = await >>= maybe (return Nothing) (pushHeader front) + + pushHeader front bs' + | S.length bs >= 11 && S.take 5 (S.drop 6 bs) == + S.pack [0x4A, 0x46, 0x49, 0x46, 0x00] = + leftover (S.drop 4 bs) >> jpg + | S.length bs >= 6 && S.take 6 bs `elem` gifs = + leftover (S.drop 6 bs) >> gif + | S.length bs >= 8 && S.take 8 bs == S.pack [137, 80, 78, 71, 13, 10, 26, 10] = + leftover (S.drop 8 bs) >> png + | S.length bs < 11 = start $ S.append bs + | otherwise = leftover bs >> return Nothing + where + bs = front bs' + + gifs = ["GIF87a", "GIF89a"] + gif = do + b <- CB.take 4 + let go x y = fromIntegral x + (fromIntegral y) * 256 + return $ case L.unpack b of + [w1, w2, h1, h2] -> Just (Size (go w1 w2) (go h1 h2), GIF) + _ -> Nothing + + png = do + CB.drop 4 + hdr <- CB.take 4 + if hdr == "IHDR" + then do + mw <- getInt 4 0 + mh <- getInt 4 0 + return $ (\w h -> (Size w h, PNG)) <$> mw <*> mh + else return Nothing + + jpg = do + mi <- getInt 2 0 + case mi of + Nothing -> return Nothing + Just i -> do + CB.drop $ i - 2 + jpgFrame + + jpgFrame = do + mx <- CB.head + case mx of + Just 255 -> do + my <- CB.head + case my of + Just 0xC0 -> do + _ <- CB.take 3 + mh <- getInt 2 0 + mw <- getInt 2 0 + return $ (\w h -> (Size w h, JPG)) <$> mw <*> mh + Just _ -> jpg + Nothing -> return Nothing + _ -> return Nothing + +getInt :: (Monad m, Integral i) + => Int + -> i + -> Consumer S.ByteString m (Maybe i) +getInt 0 i = return $ Just i +getInt len i = do + mx <- CB.head + case mx of + Nothing -> return Nothing + Just x -> getInt (len - 1) (i * 256 + fromIntegral x) diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,61 @@ +module Main (main) where + +import Control.Monad (forM_) +import Control.Monad.IO.Class (liftIO) +import Data.Default (def) +import System.Directory (doesFileExist) +import Test.Hspec + +import qualified Control.Monad.Trans.Resource as R +import qualified Data.Conduit as C +import qualified Data.Conduit.Binary as CB +import qualified Graphics.ThumbnailPlus as TP +import qualified Graphics.ThumbnailPlus.ImageSize as TPIS + + +jpn_art :: FilePath +jpn_art = "tests/data/jpn_art.jpg" + + +main :: IO () +main = hspec $ do + describe "sinkImageInfo" $ do + it "works for logo.png" $ check (Just (TP.Size 271 61, TP.PNG)) "tests/data/logo.png" + it "works for logo.jpg" $ check (Just (TP.Size 271 61, TP.JPG)) "tests/data/logo.jpg" + it "works for logo.gif" $ check (Just (TP.Size 271 61, TP.GIF)) "tests/data/logo.gif" + it "works for jpg_art.jpg" $ check (Just (TP.Size 1344 1352, TP.JPG)) jpn_art + it "rejects invalid file" $ check Nothing "tests/Main.hs" + describe "createThumbnails" $ do + let conf = def { TP.maxFileSize = 450239 + , TP.maxImageSize = TP.Size 1344 1352 + , TP.reencodeOriginal = TP.NewFileFormat TP.GIF + , TP.thumbnailSizes = [(TP.Size i i, Nothing) | i <- [3000, 512, 64]] + } + it "works for jpg_art.jpg" $ do + fps <- R.runResourceT $ do + TP.CreatedThumbnails thumbs _ <- TP.createThumbnails conf jpn_art + liftIO $ do + map TP.thumbSize thumbs `shouldBe` [TP.maxImageSize conf, TP.Size 508 512, TP.Size 63 64] + map TP.thumbFormat thumbs `shouldBe` [TP.GIF, TP.JPG, TP.JPG] + mapM_ checkThumbnail thumbs + return (map TP.thumbFp thumbs) + forM_ fps $ \fp -> doesFileExist fp `shouldReturn` False + it "rejects due to large file size" $ do + let conf' = conf { TP.maxFileSize = TP.maxFileSize conf - 1 } + R.runResourceT (TP.createThumbnails conf' jpn_art) `shouldReturn` TP.FileSizeTooLarge (TP.maxFileSize conf) + it "rejects due to large image width" $ do + -- I should use some lens :). + let conf' = conf { TP.maxImageSize = TP.Size 1343 9999 } + R.runResourceT (TP.createThumbnails conf' jpn_art) `shouldReturn` TP.ImageSizeTooLarge (TP.maxImageSize conf) + it "rejects due to large image height" $ do + -- I should use some lens :). + let conf' = conf { TP.maxImageSize = TP.Size 9999 1351 } + R.runResourceT (TP.createThumbnails conf' jpn_art) `shouldReturn` TP.ImageSizeTooLarge (TP.maxImageSize conf) + +check :: Maybe (TP.Size, TP.FileFormat) -> FilePath -> Expectation +check ex fp = do + size <- C.runResourceT $ CB.sourceFile fp C.$$ TPIS.sinkImageInfo + size `shouldBe` ex + +checkThumbnail :: TP.Thumbnail -> Expectation +checkThumbnail t = check (Just (TP.thumbSize t, TP.thumbFormat t)) (TP.thumbFp t) diff --git a/thumbnail-plus.cabal b/thumbnail-plus.cabal new file mode 100644 --- /dev/null +++ b/thumbnail-plus.cabal @@ -0,0 +1,81 @@ +name: thumbnail-plus +version: 1.0 +synopsis: Generate thumbnails easily and safely. +homepage: https://github.com/loyful/thumbnail-plus +license: MIT +license-file: LICENSE +author: Felipe Lessa, Michael Snoyman +maintainer: Felipe Lessa +copyright: (c) 2014 Prowdsponsor +category: Graphics +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +description: + This package provides every tool you need to easily and safely + generate thumbnails for JPG, GIF and PNG images. + . + By safely, we mean that this package should be able to handle + images uploaded to a public web server without any known + vulnerabilities: + . + * File sizes are constrained and checked. + . + * Image sizes are constrained and checked before the images + are loaded into memory. Uses code from the deprecated + @imagesize-conduit@ by Michael Snoyman. + . + * Optionally, the original image is reencoded before being + saved. + . + * The images are processed using the , + which is heavily battle-tested and + . + . + Please report any vulnerabilities you may find, we take strive + to make this library suitable for processing arbitrary images. + +source-repository head + type: git + location: git://github.com/loyful/thumbnail-plus.git + +library + exposed-modules: + Graphics.ThumbnailPlus + Graphics.ThumbnailPlus.ImageSize + build-depends: + base >= 4.6 && < 5, + bytestring >= 0.10, + data-default >= 0.5, + + transformers >= 0.3, + either >= 4.1, + + conduit >= 1.0, + resourcet >= 0.4, + + directory, + temporary >= 1.2, + + gd >= 3000.7.3 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +test-suite runtests + type: exitcode-stdio-1.0 + build-depends: + base, + data-default, + transformers, + conduit, + resourcet, + directory, + + thumbnail-plus, + hspec >= 1.9 + main-is: Main.hs + hs-source-dirs: tests + default-language: Haskell2010 + ghc-options: -Wall