{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}

-- |
-- Module      : Hakyll.Images.Common
-- Description : Types and utilities for Hakyll.Images
-- Copyright   : (c) Laurent P René de Cotret, 2019 - present
-- License     : BSD3
-- Maintainer  : laurent.decotret@outlook.com
-- Stability   : unstable
-- Portability : portable
module Hakyll.Images.Common
  ( Image (..),
    withImageContent,
    ImageContent,
    decodeContent,
    WithMetadata (..),
    ImageFormat (..),
    loadImage,
    encode,
  )
where

import Codec.Picture (decodeImageWithMetadata)
import Codec.Picture.Metadata (Metadatas)
import qualified Codec.Picture.Metadata as Meta
import qualified Codec.Picture.Metadata.Exif as Meta
import Codec.Picture.Saving
import Codec.Picture.Saving.WithMetadata
  ( imageToBitmapWithMetadata,
    imageToJpgWithMetadata,
    imageToPngWithMetadata,
  )
import Codec.Picture.Types (DynamicImage)
import Data.Bifunctor (second)
import Data.Binary (Binary (..))
import Data.ByteString (ByteString)
import Data.ByteString.Lazy (toStrict)
import Data.Char (toLower)
import Data.Either (fromRight)
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Hakyll.Core.Compiler (Compiler, getResourceLBS, getUnderlyingExtension)
import Hakyll.Core.Item (Item (..))
import Hakyll.Core.Writable (Writable (..))
import Prelude hiding (readFile)

-- Supported (i.e. encodable) image formats
data ImageFormat
  = Jpeg
  | Png
  | Bitmap
  | Tiff
  | Gif
  deriving (ImageFormat -> ImageFormat -> Bool
(ImageFormat -> ImageFormat -> Bool)
-> (ImageFormat -> ImageFormat -> Bool) -> Eq ImageFormat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ImageFormat -> ImageFormat -> Bool
== :: ImageFormat -> ImageFormat -> Bool
$c/= :: ImageFormat -> ImageFormat -> Bool
/= :: ImageFormat -> ImageFormat -> Bool
Eq, (forall x. ImageFormat -> Rep ImageFormat x)
-> (forall x. Rep ImageFormat x -> ImageFormat)
-> Generic ImageFormat
forall x. Rep ImageFormat x -> ImageFormat
forall x. ImageFormat -> Rep ImageFormat x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ImageFormat -> Rep ImageFormat x
from :: forall x. ImageFormat -> Rep ImageFormat x
$cto :: forall x. Rep ImageFormat x -> ImageFormat
to :: forall x. Rep ImageFormat x -> ImageFormat
Generic)

-- Automatic derivation of Binary instances requires Generic
instance Binary ImageFormat

data Image = Image
  { Image -> ImageFormat
format :: !ImageFormat,
    Image -> ByteString
image :: !ByteString
  }
  deriving (Typeable)

-- Implementation note
-- We need to keep the content of an image as a bytestring, as
-- much as possible, because Hakyll's Items must be serializable.

data WithMetadata a
  = MkWithMetadata
  { forall a. WithMetadata a -> a
getData :: !a,
    forall a. WithMetadata a -> Metadatas
getMetadata :: !Metadatas
  }

type ImageContent = WithMetadata DynamicImage

decodeContent :: ByteString -> WithMetadata DynamicImage
decodeContent :: ByteString -> WithMetadata DynamicImage
decodeContent ByteString
im = case ByteString -> Either String (DynamicImage, Metadatas)
decodeImageWithMetadata ByteString
im of
  Left String
msg -> String -> WithMetadata DynamicImage
forall a. HasCallStack => String -> a
error String
msg
  Right (DynamicImage, Metadatas)
content -> (DynamicImage -> Metadatas -> WithMetadata DynamicImage)
-> (DynamicImage, Metadatas) -> WithMetadata DynamicImage
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry DynamicImage -> Metadatas -> WithMetadata DynamicImage
forall a. a -> Metadatas -> WithMetadata a
MkWithMetadata ((Metadatas -> Metadatas)
-> (DynamicImage, Metadatas) -> (DynamicImage, Metadatas)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Metadatas -> Metadatas
pruneMetadatas (DynamicImage, Metadatas)
content)
    where
      -- \| Prune metadata to only keep tags which are absolutely necessary
      -- (of which there are very few).
      pruneMetadatas :: Metadatas -> Metadatas
      pruneMetadatas :: Metadatas -> Metadatas
pruneMetadatas Metadatas
meta =
        ((ExifTag, ExifData) -> Metadatas)
-> [(ExifTag, ExifData)] -> Metadatas
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(ExifTag
k, ExifData
v) -> Keys ExifData -> ExifData -> Metadatas
forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Meta.singleton (ExifTag -> Keys ExifData
Meta.Exif ExifTag
k) ExifData
v) ([(ExifTag, ExifData)] -> Metadatas)
-> [(ExifTag, ExifData)] -> Metadatas
forall a b. (a -> b) -> a -> b
$
          ((ExifTag, ExifData) -> Bool)
-> [(ExifTag, ExifData)] -> [(ExifTag, ExifData)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(ExifTag
k, ExifData
_) -> ExifTag
k ExifTag -> ExifTag -> Bool
forall a. Eq a => a -> a -> Bool
== ExifTag
Meta.TagOrientation) ([(ExifTag, ExifData)] -> [(ExifTag, ExifData)])
-> [(ExifTag, ExifData)] -> [(ExifTag, ExifData)]
forall a b. (a -> b) -> a -> b
$
            Metadatas -> [(ExifTag, ExifData)]
Meta.extractExifMetas Metadatas
meta

instance Functor WithMetadata where
  fmap :: forall a b. (a -> b) -> WithMetadata a -> WithMetadata b
fmap a -> b
f (MkWithMetadata a
a Metadatas
m) = (b -> Metadatas -> WithMetadata b
forall a. a -> Metadatas -> WithMetadata a
MkWithMetadata (a -> b
f a
a) Metadatas
m)

-- When writing to disk, we ignore the image format.
-- Trusting users to route correctly.
instance Writable Image where
  -- Write the bytestring content
  write :: String -> Item Image -> IO ()
write String
fp Item Image
item = String -> Item ByteString -> IO ()
forall a. Writable a => String -> Item a -> IO ()
write String
fp (Image -> ByteString
image (Image -> ByteString) -> Item Image -> Item ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Item Image
item)

-- Binary instance looks similar to the binary instance for a Hakyll Item
instance Binary Image where
  put :: Image -> Put
put (Image ImageFormat
fmt ByteString
content) = ImageFormat -> Put
forall t. Binary t => t -> Put
put ImageFormat
fmt Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> Put
forall t. Binary t => t -> Put
put ByteString
content
  get :: Get Image
get = ImageFormat -> ByteString -> Image
Image (ImageFormat -> ByteString -> Image)
-> Get ImageFormat -> Get (ByteString -> Image)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ImageFormat
forall t. Binary t => Get t
get Get (ByteString -> Image) -> Get ByteString -> Get Image
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get ByteString
forall t. Binary t => Get t
get

-- | Load an image from a file.
-- This function can be combined with other compilers.
--
-- @
-- match "*.jpg" $ do
--    route idRoute
--    compile $ loadImage >>= compressJpgCompiler 50
-- @
loadImage :: Compiler (Item Image)
loadImage :: Compiler (Item Image)
loadImage = do
  Item ByteString
content <- (ByteString -> ByteString) -> Item ByteString -> Item ByteString
forall a b. (a -> b) -> Item a -> Item b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
toStrict (Item ByteString -> Item ByteString)
-> Compiler (Item ByteString) -> Compiler (Item ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Compiler (Item ByteString)
getResourceLBS
  ImageFormat
fmt <- String -> ImageFormat
fromExt (String -> ImageFormat) -> Compiler String -> Compiler ImageFormat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Compiler String
getUnderlyingExtension
  Item Image -> Compiler (Item Image)
forall a. a -> Compiler a
forall (m :: * -> *) a. Monad m => a -> m a
return (Item Image -> Compiler (Item Image))
-> Item Image -> Compiler (Item Image)
forall a b. (a -> b) -> a -> b
$ ImageFormat -> ByteString -> Image
Image ImageFormat
fmt (ByteString -> Image) -> Item ByteString -> Item Image
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Item ByteString
content

-- | Translation between file extensions and image formats.
-- It is important to keep track of image formats because Hakyll
-- compilers provides raw bytestrings and filenames.
--
-- This function is case-insensitive
fromExt :: String -> ImageFormat
fromExt :: String -> ImageFormat
fromExt String
ext = String -> ImageFormat
fromExt' (String -> ImageFormat) -> String -> ImageFormat
forall a b. (a -> b) -> a -> b
$ Char -> Char
toLower (Char -> Char) -> String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
ext
  where
    fromExt' :: String -> ImageFormat
fromExt' String
".jpeg" = ImageFormat
Jpeg
    fromExt' String
".jpg" = ImageFormat
Jpeg
    fromExt' String
".png" = ImageFormat
Png
    fromExt' String
".bmp" = ImageFormat
Bitmap
    fromExt' String
".tif" = ImageFormat
Tiff
    fromExt' String
".tiff" = ImageFormat
Tiff
    fromExt' String
".gif" = ImageFormat
Gif
    fromExt' String
ext' = String -> ImageFormat
forall a. HasCallStack => String -> a
error (String -> ImageFormat) -> String -> ImageFormat
forall a b. (a -> b) -> a -> b
$ String
"Unsupported format: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
ext'

-- Encode images based on file extension
--
-- Unfortunately, the upstream library `JuicyPixels` does not have support
-- for encoding metadata of some image formats, including `Tiff` and `Gif`.
encode :: ImageFormat -> ImageContent -> Image
encode :: ImageFormat -> WithMetadata DynamicImage -> Image
encode ImageFormat
Jpeg (MkWithMetadata DynamicImage
im Metadatas
meta) = ImageFormat -> ByteString -> Image
Image ImageFormat
Jpeg (ByteString -> Image) -> ByteString -> Image
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString
toStrict (ByteString -> ByteString)
-> (DynamicImage -> ByteString) -> DynamicImage -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Metadatas -> DynamicImage -> ByteString
imageToJpgWithMetadata Int
100 Metadatas
meta) DynamicImage
im
encode ImageFormat
Png (MkWithMetadata DynamicImage
im Metadatas
meta) = ImageFormat -> ByteString -> Image
Image ImageFormat
Png (ByteString -> Image) -> ByteString -> Image
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString
toStrict (ByteString -> ByteString)
-> (DynamicImage -> ByteString) -> DynamicImage -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Metadatas -> DynamicImage -> ByteString
imageToPngWithMetadata Metadatas
meta) DynamicImage
im
encode ImageFormat
Bitmap (MkWithMetadata DynamicImage
im Metadatas
meta) = ImageFormat -> ByteString -> Image
Image ImageFormat
Bitmap (ByteString -> Image) -> ByteString -> Image
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString
toStrict (ByteString -> ByteString)
-> (DynamicImage -> ByteString) -> DynamicImage -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Metadatas -> DynamicImage -> ByteString
imageToBitmapWithMetadata Metadatas
meta) DynamicImage
im
encode ImageFormat
Tiff (MkWithMetadata DynamicImage
im Metadatas
_) = ImageFormat -> ByteString -> Image
Image ImageFormat
Tiff (ByteString -> Image) -> ByteString -> Image
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString
toStrict (ByteString -> ByteString)
-> (DynamicImage -> ByteString) -> DynamicImage -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> ByteString
imageToTiff) DynamicImage
im
encode ImageFormat
Gif (MkWithMetadata DynamicImage
im Metadatas
_) = ImageFormat -> ByteString -> Image
Image ImageFormat
Gif (ByteString -> Image) -> ByteString -> Image
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString
toStrict (ByteString -> ByteString)
-> (DynamicImage -> ByteString) -> DynamicImage -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String ByteString -> ByteString
forall b a. b -> Either a b -> b
fromRight (String -> ByteString
forall a. HasCallStack => String -> a
error String
"Could not parse gif") (Either String ByteString -> ByteString)
-> (DynamicImage -> Either String ByteString)
-> DynamicImage
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> Either String ByteString
imageToGif) DynamicImage
im

-- | Map over the content of an `Image`, decoded into an `ImageContent`.
withImageContent ::
  (ImageContent -> ImageContent) ->
  -- | Encoder function
  (ImageFormat -> ImageContent -> Image) ->
  (Image -> Image)
withImageContent :: (WithMetadata DynamicImage -> WithMetadata DynamicImage)
-> (ImageFormat -> WithMetadata DynamicImage -> Image)
-> Image
-> Image
withImageContent WithMetadata DynamicImage -> WithMetadata DynamicImage
f ImageFormat -> WithMetadata DynamicImage -> Image
encoder (Image ImageFormat
fmt ByteString
bts) =
  let content :: WithMetadata DynamicImage
content = ByteString -> WithMetadata DynamicImage
decodeContent ByteString
bts
   in ImageFormat -> WithMetadata DynamicImage -> Image
encoder ImageFormat
fmt (WithMetadata DynamicImage -> Image)
-> WithMetadata DynamicImage -> Image
forall a b. (a -> b) -> a -> b
$ WithMetadata DynamicImage -> WithMetadata DynamicImage
f WithMetadata DynamicImage
content