thumbnail-plus (empty) → 1.0
raw patch · 7 files changed
+527/−0 lines, 7 filesdep +basedep +bytestringdep +conduitsetup-changed
Dependencies added: base, bytestring, conduit, data-default, directory, either, gd, hspec, resourcet, temporary, thumbnail-plus, transformers
Files
- LICENSE +31/−0
- README.md +4/−0
- Setup.hs +2/−0
- src/Graphics/ThumbnailPlus.hs +238/−0
- src/Graphics/ThumbnailPlus/ImageSize.hs +110/−0
- tests/Main.hs +61/−0
- thumbnail-plus.cabal +81/−0
+ LICENSE view
@@ -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 <felipe.lessa@gmail.com> 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.
+ README.md view
@@ -0,0 +1,4 @@+thumbnail-plus+==============++Generate thumbnails easily and safely.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Graphics/ThumbnailPlus.hs view
@@ -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
+ src/Graphics/ThumbnailPlus/ImageSize.hs view
@@ -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)
+ tests/Main.hs view
@@ -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)
+ thumbnail-plus.cabal view
@@ -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 <felipe.lessa@gmail.com>+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 <http://libgd.bitbucket.org/ GD library>,+ which is heavily battle-tested and+ <http://www.cvedetails.com/vulnerability-list/vendor_id-2678/Gd-Graphics-Library.html audited by many pairs of eyeballs>.+ .+ 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