module Yesod.Media.Simple
( serve
, serveHandler
, RenderContent(..)
, serveDiagram
, SizedDiagram(..)
, PixelList(..)
, Jpeg(..)
, imageToDiagramEmb
, imageToDiagramExt
, diagramToImage
) where
import Codec.Picture
import Control.Exception (finally)
import qualified Data.ByteString.Lazy as LBS
import Data.Monoid (Any)
import qualified Data.Vector.Storable as V
import Data.Word
import Diagrams.Backend.Cairo
import Diagrams.Core
import Diagrams.Prelude (V2)
import Diagrams.Size (SizeSpec)
import qualified Diagrams.TwoD.Image as Dia
import Diagrams.TwoD.Size
import System.Directory (getTemporaryDirectory)
import System.Environment (lookupEnv, setEnv, unsetEnv)
import System.IO (openTempFile, hClose)
import Yesod
serve :: RenderContent a => a -> IO ()
serve = useDefaultPort . warpEnv . liteApp . onMethod "GET" . dispatchTo . renderContent
serveHandler :: RenderContent a => LiteHandler a -> IO ()
serveHandler = useDefaultPort . warpEnv . liteApp . onMethod "GET" . dispatchTo . (renderContent =<<)
class RenderContent a where
renderContent :: a -> HandlerT site IO TypedContent
instance RenderContent a => RenderContent (IO a) where
renderContent f = liftIO f >>= renderContent
serveDiagram :: Diagram Cairo -> IO ()
serveDiagram = serve
instance RenderContent (QDiagram Cairo V2 Double Any) where
renderContent = renderContent . SizedDiagram (mkWidth 640)
data SizedDiagram = SizedDiagram (SizeSpec V2 Double) (Diagram Cairo)
instance RenderContent SizedDiagram where
renderContent (SizedDiagram sz dia) = do
png <- liftIO $ do
path <- getTempPath "out.png"
renderCairo path sz dia
LBS.readFile path
return $ TypedContent typePng (toContent png)
renderPng :: (MonadHandler m, PngSavable a) => Image a -> m TypedContent
renderPng = return . TypedContent typePng . toContent . encodePng
instance RenderContent (Image PixelRGBA8) where renderContent = renderPng
instance RenderContent (Image PixelRGB8) where renderContent = renderPng
instance RenderContent (Image PixelYA8) where renderContent = renderPng
instance RenderContent (Image Pixel8) where renderContent = renderPng
#if MIN_VERSION_JuicyPixels(3,0,0)
instance RenderContent (Image PixelRGBA16) where renderContent = renderPng
instance RenderContent (Image PixelRGB16) where renderContent = renderPng
instance RenderContent (Image PixelYA16) where renderContent = renderPng
instance RenderContent (Image Pixel16) where renderContent = renderPng
#endif
data PixelList = PixelList Int Int [[(Word8, Word8, Word8)]]
pixelListToImage :: PixelList -> Image PixelRGB8
pixelListToImage (PixelList w h pixels) =
Image w h $ V.fromList $ concat $ concat
[ [ [r, g, b]
| (r, g, b) <- take w $ row ++ repeat (0,0,0)
]
| row <- take h $ pixels ++ repeat (repeat (0,0,0))
]
instance RenderContent PixelList where
renderContent = renderContent . pixelListToImage
data Jpeg = Jpeg Word8 (Image PixelYCbCr8)
instance RenderContent Jpeg where
renderContent (Jpeg q x) =
return $ TypedContent typeJpeg $ toContent $ encodeJpegAtQuality q x
imageToDiagramEmb :: (Renderable (Dia.DImage (N b) Dia.Embedded) b, V b ~ V2, TypeableFloat (N b)) => DynamicImage -> Diagram b
imageToDiagramEmb img =
imageFromDynamicImage img $ \img' ->
let w = fromIntegral (imageWidth img')
h = fromIntegral (imageHeight img')
in Dia.image (Dia.DImage (Dia.ImageRaster img) w h mempty)
imageToDiagramExt :: (Renderable (Dia.DImage (N b) Dia.External) b, V b ~ V2, TypeableFloat (N b)) => DynamicImage -> IO (Diagram b)
imageToDiagramExt img =
imageFromDynamicImage img $ \img' -> do
path <- getTempPath "out.png"
either fail (\_ -> return ()) =<< writeDynamicPng path img
let w = fromIntegral (imageWidth img')
h = fromIntegral (imageHeight img')
return (Dia.image (Dia.DImage (Dia.ImageRef path) w h mempty))
imageFromDynamicImage :: DynamicImage -> (forall a. Image a -> b) -> b
imageFromDynamicImage (ImageY8 img) f = f img
imageFromDynamicImage (ImageY16 img) f = f img
imageFromDynamicImage (ImageYF img) f = f img
imageFromDynamicImage (ImageYA8 img) f = f img
imageFromDynamicImage (ImageYA16 img) f = f img
imageFromDynamicImage (ImageRGB8 img) f = f img
imageFromDynamicImage (ImageRGB16 img) f = f img
imageFromDynamicImage (ImageRGBF img) f = f img
imageFromDynamicImage (ImageRGBA8 img) f = f img
imageFromDynamicImage (ImageRGBA16 img) f = f img
imageFromDynamicImage (ImageYCbCr8 img) f = f img
imageFromDynamicImage (ImageCMYK8 img) f = f img
imageFromDynamicImage (ImageCMYK16 img) f = f img
diagramToImage :: Diagram Cairo -> Double -> Double -> IO (Either String DynamicImage)
diagramToImage dia w h = do
path <- getTempPath "out.png"
renderCairo path (dims2D w h) dia
readPng path
useDefaultPort :: IO () -> IO ()
useDefaultPort inner = do
mport <- lookupEnv "PORT"
case mport of
Just port -> do
putStrLn $ "Running server on localhost:" ++ port
inner
Nothing -> do
setEnv "PORT" "3000"
inner `finally` unsetEnv "PORT"
getTempPath :: FilePath -> IO FilePath
getTempPath base = do
tempDir <- getTemporaryDirectory
(path, handle) <- openTempFile tempDir base
hClose handle
return path