module Yesod.Content.PDF
(
uri2PDF
, html2PDF
, PDF(..)
, typePDF
, def
, WkhtmltopdfOptions
, wkCollate
, wkCopies
, wkGrayscale
, wkLowQuality
, wkPageSize
, wkOrientation
, wkTitle
, wkMarginBottom
, wkMarginLeft
, wkMarginRight
, wkMarginTop
, wkZoom
, wkJavascriptDelay
, PageSize(..)
, Orientation(..)
, UnitReal(..)
) where
import Prelude
import Blaze.ByteString.Builder.ByteString
import Control.Monad.IO.Class (MonadIO(..))
import Data.ByteString
import Data.ByteString.Builder (hPutBuilder)
import Data.Conduit
import Data.Default (Default(..))
import Network.URI
import System.IO
import System.IO.Temp
import System.Process
import Text.Blaze.Html
import Text.Blaze.Html.Renderer.Utf8
import Yesod.Core.Content
newtype PDF = PDF { pdfBytes :: ByteString }
deriving (Eq, Ord, Read, Show)
typePDF :: ContentType
typePDF = "application/pdf"
instance HasContentType PDF where
getContentType _ = typePDF
instance ToTypedContent PDF where
toTypedContent = TypedContent typePDF . toContent
instance ToContent PDF where
toContent (PDF bs) = ContentSource $ do
yield $ Chunk $ fromByteString bs
uri2PDF :: MonadIO m => WkhtmltopdfOptions -> URI -> m PDF
uri2PDF opts = wkhtmltopdf opts . flip ($) . show
html2PDF :: MonadIO m => WkhtmltopdfOptions -> Html -> m PDF
html2PDF opts html =
wkhtmltopdf opts $ \inner ->
withSystemTempFile "input.html" $ \tempHtmlFp tempHtmlHandle -> do
hSetBinaryMode tempHtmlHandle True
hSetBuffering tempHtmlHandle $ BlockBuffering Nothing
hPutBuilder tempHtmlHandle $ renderHtmlBuilder html
hClose tempHtmlHandle
inner tempHtmlFp
wkhtmltopdf :: MonadIO m => WkhtmltopdfOptions -> ((String -> IO PDF) -> IO PDF) -> m PDF
wkhtmltopdf opts setupInput =
liftIO $
withSystemTempFile "output.pdf" $ \tempOutputFp tempOutputHandle -> do
hClose tempOutputHandle
setupInput $ \inputArg -> do
let args = toArgs opts ++ [inputArg, tempOutputFp]
(_, _, _, pHandle) <- createProcess (proc "wkhtmltopdf" args)
_ <- waitForProcess pHandle
PDF <$> Data.ByteString.readFile tempOutputFp
data WkhtmltopdfOptions =
WkhtmltopdfOptions
{ wkCollate :: Bool
, wkCopies :: Int
, wkGrayscale :: Bool
, wkLowQuality :: Bool
, wkPageSize :: PageSize
, wkOrientation :: Orientation
, wkTitle :: Maybe String
, wkMarginBottom :: UnitReal
, wkMarginLeft :: UnitReal
, wkMarginRight :: UnitReal
, wkMarginTop :: UnitReal
, wkZoom :: Double
, wkJavascriptDelay :: Maybe Int
} deriving (Eq, Ord, Show)
instance Default WkhtmltopdfOptions where
def = WkhtmltopdfOptions
{ wkCollate = True
, wkCopies = 1
, wkGrayscale = False
, wkLowQuality = False
, wkPageSize = A4
, wkOrientation = Portrait
, wkTitle = Nothing
, wkMarginBottom = Mm 10
, wkMarginLeft = Mm 0
, wkMarginRight = Mm 0
, wkMarginTop = Mm 10
, wkZoom = 1
, wkJavascriptDelay = Nothing
}
data PageSize =
A4
| Letter
| OtherPageSize String
| CustomPageSize UnitReal UnitReal
deriving (Eq, Ord, Show)
data Orientation =
Portrait
| Landscape
deriving (Eq, Ord, Show, Enum, Bounded)
data UnitReal =
Mm Double
| Cm Double
| OtherUnitReal String
deriving (Eq, Ord, Show)
class ToArgs a where
toArgs :: a -> [String]
instance ToArgs WkhtmltopdfOptions where
toArgs opts =
[ "--quiet"
, if wkCollate opts then "--collate" else "--no-collate"
, "--copies", show (wkCopies opts)
, "--zoom", show (wkZoom opts)
] ++
Prelude.concat
[ [ "--grayscale" | True <- [wkGrayscale opts] ]
, [ "--lowquality" | True <- [wkLowQuality opts] ]
, toArgs (wkPageSize opts)
, toArgs (wkOrientation opts)
, maybe [] (\t -> ["--title", t ]) (wkTitle opts)
, maybe [] (\d -> ["--javascript-delay", show d]) (wkJavascriptDelay opts)
, "--margin-bottom" : toArgs (wkMarginBottom opts)
, "--margin-left" : toArgs (wkMarginLeft opts)
, "--margin-right" : toArgs (wkMarginRight opts)
, "--margin-top" : toArgs (wkMarginTop opts)
]
instance ToArgs PageSize where
toArgs A4 = ["--page-size", "A4"]
toArgs Letter = ["--page-size", "Letter"]
toArgs (OtherPageSize s) = ["--page-size", s]
toArgs (CustomPageSize h w) = ("--page-height" : toArgs h) ++ ("--page-width" : toArgs w)
instance ToArgs Orientation where
toArgs o = ["--orientation", show o]
instance ToArgs UnitReal where
toArgs (Mm x) = [show x ++ "mm"]
toArgs (Cm x) = [show x ++ "cm"]
toArgs (OtherUnitReal s) = [s]