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
data Configuration =
Configuration
{ maxFileSize :: !Integer
, maxImageSize :: !Size
, reencodeOriginal :: !ReencodeOriginal
, thumbnailSizes :: [(Size, Maybe FileFormat)]
, temporaryDirectory :: IO FilePath
} 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
}
data ReencodeOriginal =
Never
| SameFileFormat
| NewFileFormat !FileFormat
deriving (Eq, Ord, Show, T.Typeable)
calculateThumbnailSize
:: Size
-> Size
-> Size
calculateThumbnailSize (Size ow oh) (Size tw th) =
let
wByH = ow * th `div` oh
hByW = oh * tw `div` ow
in if wByH > tw
then Size tw hByW
else Size wByH th
createThumbnails
:: R.MonadResource m
=> Configuration
-> FilePath
-> 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 =
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
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)
PNG -> GD.savePngFile
return Thumbnail { thumbFp = tmpFp
, thumbSize = size
, thumbFormat = ff
, thumbReleaseKey = NoShow relTmpFile
}
gdFreeImage :: GD.Image -> IO ()
gdFreeImage img = GD.withImage (return img) (const $ return ())
ignoringIOErrors :: IO () -> IO ()
ignoringIOErrors ioe = ioe `E.catch` (\e -> const (return ()) (e :: IOError))
data CreatedThumbnails =
FileSizeTooLarge !Integer
| ImageSizeTooLarge !Size
| ImageFormatUnrecognized
| CreatedThumbnails ![Thumbnail] !(NoShow R.ReleaseKey)
deriving (Eq, Show, T.Typeable)
data Thumbnail =
Thumbnail
{ thumbFp :: !FilePath
, thumbSize :: !Size
, thumbFormat :: !FileFormat
, thumbReleaseKey :: !(NoShow R.ReleaseKey)
} deriving (Eq, Show, T.Typeable)
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