{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE ScopedTypeVariables        #-}
-- |
-- Module      : Hakyll.Images.CompressJpg
-- Description : Hakyll compiler to compress Jpeg images
-- Copyright   : (c) Laurent P René de Cotret, 2019 - present
-- License     : BSD3
-- Maintainer  : laurent.decotret@outlook.com
-- Stability   : unstable
-- Portability : portable
--
-- This module defines a Hakyll compiler, 'compressJpgCompiler', which can be used to
-- re-encode Jpeg images at a lower quality during website compilation. Original images are
-- left unchanged, but compressed images can be up to 10x smaller.
--
-- The @compressJpgCompiler@ is expected to be used like this:
--
-- @
--     import Hakyll
--     import Hakyll.Images        ( loadImage
--                                 , compressJpgCompiler
--                                 )
--
--     hakyll $ do
--
--         -- Compress all source Jpegs to a Jpeg quality of 50
--         match "images/**.jpg" $ do
--             route idRoute
--             compile $ loadImage
--                 >>= compressJpgCompiler 50
--
--         (... omitted ...)
-- @
module Hakyll.Images.CompressJpg
  ( JpgQuality,
    compressJpgCompiler,
    compressJpg,
  )
where

import Codec.Picture.Types (DynamicImage(..), dropTransparency, pixelMap)
import qualified Codec.Picture.Types as Picture
import Codec.Picture.Metadata (Metadatas, SourceFormat(SourceJpeg), basicMetadata) 
import qualified Codec.Picture.Metadata as Meta
import Codec.Picture.Metadata.Exif (ExifTag(TagOrientation))
import Codec.Picture.Jpg (JpgEncodable, decodeJpegWithMetadata, encodeDirectJpegAtQualityWithMetadata)
import Data.ByteString.Lazy (toStrict)
import Data.ByteString (ByteString) 
import Hakyll.Core.Compiler (Compiler)
import Hakyll.Core.Item (Item (..))
import Hakyll.Images.Common
  ( Image (..),
    ImageFormat (..),
    format,
    image,
  )
import Numeric.Natural (Natural)


-- | Jpeg encoding quality, from 0 (lower quality) to 100 (best quality).
-- @since 1.2.0
newtype JpgQuality = JpgQuality Natural
  deriving (Integer -> JpgQuality
JpgQuality -> JpgQuality
JpgQuality -> JpgQuality -> JpgQuality
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> JpgQuality
$cfromInteger :: Integer -> JpgQuality
signum :: JpgQuality -> JpgQuality
$csignum :: JpgQuality -> JpgQuality
abs :: JpgQuality -> JpgQuality
$cabs :: JpgQuality -> JpgQuality
negate :: JpgQuality -> JpgQuality
$cnegate :: JpgQuality -> JpgQuality
* :: JpgQuality -> JpgQuality -> JpgQuality
$c* :: JpgQuality -> JpgQuality -> JpgQuality
- :: JpgQuality -> JpgQuality -> JpgQuality
$c- :: JpgQuality -> JpgQuality -> JpgQuality
+ :: JpgQuality -> JpgQuality -> JpgQuality
$c+ :: JpgQuality -> JpgQuality -> JpgQuality
Num, JpgQuality -> JpgQuality -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JpgQuality -> JpgQuality -> Bool
$c/= :: JpgQuality -> JpgQuality -> Bool
== :: JpgQuality -> JpgQuality -> Bool
$c== :: JpgQuality -> JpgQuality -> Bool
Eq, Int -> JpgQuality
JpgQuality -> Int
JpgQuality -> [JpgQuality]
JpgQuality -> JpgQuality
JpgQuality -> JpgQuality -> [JpgQuality]
JpgQuality -> JpgQuality -> JpgQuality -> [JpgQuality]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: JpgQuality -> JpgQuality -> JpgQuality -> [JpgQuality]
$cenumFromThenTo :: JpgQuality -> JpgQuality -> JpgQuality -> [JpgQuality]
enumFromTo :: JpgQuality -> JpgQuality -> [JpgQuality]
$cenumFromTo :: JpgQuality -> JpgQuality -> [JpgQuality]
enumFromThen :: JpgQuality -> JpgQuality -> [JpgQuality]
$cenumFromThen :: JpgQuality -> JpgQuality -> [JpgQuality]
enumFrom :: JpgQuality -> [JpgQuality]
$cenumFrom :: JpgQuality -> [JpgQuality]
fromEnum :: JpgQuality -> Int
$cfromEnum :: JpgQuality -> Int
toEnum :: Int -> JpgQuality
$ctoEnum :: Int -> JpgQuality
pred :: JpgQuality -> JpgQuality
$cpred :: JpgQuality -> JpgQuality
succ :: JpgQuality -> JpgQuality
$csucc :: JpgQuality -> JpgQuality
Enum, Eq JpgQuality
JpgQuality -> JpgQuality -> Bool
JpgQuality -> JpgQuality -> Ordering
JpgQuality -> JpgQuality -> JpgQuality
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: JpgQuality -> JpgQuality -> JpgQuality
$cmin :: JpgQuality -> JpgQuality -> JpgQuality
max :: JpgQuality -> JpgQuality -> JpgQuality
$cmax :: JpgQuality -> JpgQuality -> JpgQuality
>= :: JpgQuality -> JpgQuality -> Bool
$c>= :: JpgQuality -> JpgQuality -> Bool
> :: JpgQuality -> JpgQuality -> Bool
$c> :: JpgQuality -> JpgQuality -> Bool
<= :: JpgQuality -> JpgQuality -> Bool
$c<= :: JpgQuality -> JpgQuality -> Bool
< :: JpgQuality -> JpgQuality -> Bool
$c< :: JpgQuality -> JpgQuality -> Bool
compare :: JpgQuality -> JpgQuality -> Ordering
$ccompare :: JpgQuality -> JpgQuality -> Ordering
Ord, Num JpgQuality
Ord JpgQuality
JpgQuality -> Rational
forall a. Num a -> Ord a -> (a -> Rational) -> Real a
toRational :: JpgQuality -> Rational
$ctoRational :: JpgQuality -> Rational
Real, Enum JpgQuality
Real JpgQuality
JpgQuality -> Integer
JpgQuality -> JpgQuality -> (JpgQuality, JpgQuality)
JpgQuality -> JpgQuality -> JpgQuality
forall a.
Real a
-> Enum a
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> (a, a))
-> (a -> a -> (a, a))
-> (a -> Integer)
-> Integral a
toInteger :: JpgQuality -> Integer
$ctoInteger :: JpgQuality -> Integer
divMod :: JpgQuality -> JpgQuality -> (JpgQuality, JpgQuality)
$cdivMod :: JpgQuality -> JpgQuality -> (JpgQuality, JpgQuality)
quotRem :: JpgQuality -> JpgQuality -> (JpgQuality, JpgQuality)
$cquotRem :: JpgQuality -> JpgQuality -> (JpgQuality, JpgQuality)
mod :: JpgQuality -> JpgQuality -> JpgQuality
$cmod :: JpgQuality -> JpgQuality -> JpgQuality
div :: JpgQuality -> JpgQuality -> JpgQuality
$cdiv :: JpgQuality -> JpgQuality -> JpgQuality
rem :: JpgQuality -> JpgQuality -> JpgQuality
$crem :: JpgQuality -> JpgQuality -> JpgQuality
quot :: JpgQuality -> JpgQuality -> JpgQuality
$cquot :: JpgQuality -> JpgQuality -> JpgQuality
Integral)


-- | @JpgQuality@ smart constructor. Ensures that @JpgQuality@ is always
-- in the interval [0, 100]. Numbers outside this range will result in either
-- a quality of 0 or 100.
--
-- @since 1.2.0
mkJpgQuality :: Integral a => a -> JpgQuality
mkJpgQuality :: forall a. Integral a => a -> JpgQuality
mkJpgQuality a
q | a
q forall a. Ord a => a -> a -> Bool
< a
0     = Natural -> JpgQuality
JpgQuality Natural
0
               | a
q forall a. Ord a => a -> a -> Bool
> a
100   = Natural -> JpgQuality
JpgQuality Natural
100
               | Bool
otherwise = Natural -> JpgQuality
JpgQuality (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
q)


-- | Compress a JPG bytestring to a certain quality setting.
-- The quality should be between 0 (lowest quality) and 100 (best quality).
-- An error is raised if the image cannot be decoded.
--
-- In the rare case where the JPEG data contains transparency information, it will be dropped.
compressJpg :: Integral a => a -> Image -> Image
compressJpg :: forall a. Integral a => a -> Image -> Image
compressJpg a
quality' Image
src =
  if Image -> ImageFormat
format Image
src forall a. Eq a => a -> a -> Bool
/= ImageFormat
Jpeg
    then forall a. HasCallStack => [Char] -> a
error [Char]
"Image is not a JPEG."
    -- It is important to preserve some metadata, such as orientation (issue #11).
    else case ByteString -> Either [Char] (DynamicImage, Metadatas)
decodeJpegWithMetadata forall a b. (a -> b) -> a -> b
$ Image -> ByteString
image Image
src of
      Left [Char]
msg -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Loading the image failed for the following reason: " forall a. Semigroup a => a -> a -> a
<> [Char]
msg
      Right (DynamicImage
dynImage, Metadatas
meta) -> 
         ImageFormat -> ByteString -> Image
Image ImageFormat
Jpeg forall a b. (a -> b) -> a -> b
$ case DynamicImage
dynImage of 
          (ImageY8 Image Pixel8
img)     -> (forall q px.
(Integral q, JpgEncodable px) =>
q -> Metadatas -> Image px -> ByteString
encodeJpeg JpgQuality
quality Metadatas
meta Image Pixel8
img)
          (ImageCMYK8 Image PixelCMYK8
img)  -> (forall q px.
(Integral q, JpgEncodable px) =>
q -> Metadatas -> Image px -> ByteString
encodeJpeg JpgQuality
quality Metadatas
meta Image PixelCMYK8
img)
          (ImageRGB8 Image PixelRGB8
img)   -> (forall q px.
(Integral q, JpgEncodable px) =>
q -> Metadatas -> Image px -> ByteString
encodeJpeg JpgQuality
quality Metadatas
meta Image PixelRGB8
img)
          (ImageYCbCr8 Image PixelYCbCr8
img) -> (forall q px.
(Integral q, JpgEncodable px) =>
q -> Metadatas -> Image px -> ByteString
encodeJpeg JpgQuality
quality Metadatas
meta Image PixelYCbCr8
img)
          -- Out of the 5 possible image types that can be returned by `decodeJpegWithMetadata`, only 1
          -- has transparency. This is also the only image type which cannot be re-encoded directly;
          -- we need to remove transparency.
          (ImageYA8 Image PixelYA8
img)    -> (forall q px.
(Integral q, JpgEncodable px) =>
q -> Metadatas -> Image px -> ByteString
encodeJpeg JpgQuality
quality Metadatas
meta (forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap forall a b. TransparentPixel a b => a -> b
dropTransparency Image PixelYA8
img))
          DynamicImage
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"Loading the image failed because the color space is unknown." 
  where 
    quality :: JpgQuality
quality = forall a. Integral a => a -> JpgQuality
mkJpgQuality a
quality'


-- | Encode a JPEG image at a particular quality, preserving some metadata.
encodeJpeg :: (Integral q, JpgEncodable px) 
           => q 
           -> Metadatas 
           -> Picture.Image px 
           -> ByteString
encodeJpeg :: forall q px.
(Integral q, JpgEncodable px) =>
q -> Metadatas -> Image px -> ByteString
encodeJpeg q
qual Metadatas
meta img :: Image px
img@Picture.Image{Int
Vector (PixelBaseComponent px)
imageWidth :: forall a. Image a -> Int
imageHeight :: forall a. Image a -> Int
imageData :: forall a. Image a -> Vector (PixelBaseComponent a)
imageData :: Vector (PixelBaseComponent px)
imageHeight :: Int
imageWidth :: Int
..} 
  = ByteString -> ByteString
toStrict forall a b. (a -> b) -> a -> b
$ forall px.
JpgEncodable px =>
Pixel8 -> Metadatas -> Image px -> ByteString
encodeDirectJpegAtQualityWithMetadata (forall a b. (Integral a, Num b) => a -> b
fromIntegral q
qual) Metadatas
newmeta Image px
img
  where
    -- We want to preserve Exif orientation metadata, which is important for presentation (see #11)
    -- However, other metadata tags are notoriously finicky and can leads to corrupted
    -- files. 
    exifOrientationMeta :: Metadatas
exifOrientationMeta = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(ExifTag
k, ExifData
v) -> forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Meta.singleton (ExifTag -> Keys ExifData
Meta.Exif ExifTag
k) ExifData
v) 
                        forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (\(ExifTag
k, ExifData
_) -> ExifTag
k forall a. Eq a => a -> a -> Bool
== ExifTag
TagOrientation) 
                        forall a b. (a -> b) -> a -> b
$ Metadatas -> [(ExifTag, ExifData)]
Meta.extractExifMetas Metadatas
meta
    newmeta :: Metadatas
newmeta = Metadatas
exifOrientationMeta forall a. Semigroup a => a -> a -> a
<> forall nSize.
Integral nSize =>
SourceFormat -> nSize -> nSize -> Metadatas
basicMetadata SourceFormat
SourceJpeg Int
imageWidth Int
imageHeight


-- | Compiler that compresses a JPG image to a certain quality setting.
-- The quality should be between 0 (lowest quality) and 100 (best quality).
-- Values outside of this range will be normalized to the interval [0, 100].
-- An error is raised if the image cannot be decoded.
--
-- @
-- match "*.jpg" $ do
--     route idRoute
--     compile $ loadImage
--         >>= compressJpgCompiler 50
-- @
compressJpgCompiler :: Integral a => a -> Item Image -> Compiler (Item Image)
compressJpgCompiler :: forall a. Integral a => a -> Item Image -> Compiler (Item Image)
compressJpgCompiler a
quality = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Integral a => a -> Image -> Image
compressJpg a
quality)