{-# LANGUAGE OverloadedStrings, TemplateHaskell, GADTs, KindSignatures, CPP, BangPatterns, ScopedTypeVariables #-} -- | blank-canvas is a Haskell binding to the complete HTML5 Canvas -- API. blank-canvas allows Haskell users to write, in Haskell, -- interactive images onto their web browsers. blank-canvas gives -- the users a single full-window canvas, and provides many -- well-documented functions for rendering images. module Graphics.Blank ( -- * Starting blank-canvas blankCanvas , Options(..) -- ** 'send'ing to the Graphics 'DeviceContext' , DeviceContext -- abstact , send -- * HTML5 Canvas API -- | See for the JavaScript -- version of this API. , Canvas -- abstact -- ** Canvas element , height , width , toDataURL -- ** 2D Context , save , restore -- ** Transformation , scale , rotate , translate , transform , setTransform -- ** Image drawing , Image -- abstract class , drawImage -- ** Compositing , globalAlpha , globalCompositeOperation -- ** Line styles , lineWidth , lineCap , lineJoin , miterLimit , LineEndCap(..) , LineJoinCorner(..) -- ** Colors, styles and shadows , strokeStyle , fillStyle , shadowOffsetX , shadowOffsetY , shadowBlur , shadowColor , createLinearGradient , createRadialGradient , createPattern , addColorStop , RepeatDirection(..) , CanvasGradient , CanvasPattern -- ** Paths , beginPath , closePath , fill , stroke , clip , moveTo , lineTo , quadraticCurveTo , bezierCurveTo , arcTo , arc , rect , isPointInPath -- ** Text , font , textAlign , textBaseline , fillText , strokeText , measureText , TextAnchorAlignment(..) , TextBaselineAlignment(..) , TextMetrics(..) -- ** Rectangles , clearRect , fillRect , strokeRect -- ** Pixel manipulation , getImageData , putImageData , ImageData(..) -- * blank-canvas Extensions -- ** Reading from 'Canvas' , newImage , CanvasImage -- abstract -- ** 'DeviceContext' attributes , devicePixelRatio -- ** 'CanvasContext', and off-screen Canvas. , CanvasContext , newCanvas , with , myCanvasContext , deviceCanvasContext -- ** Syncing , sync -- ** Debugging , console_log , eval , JSArg(..) -- ** Drawing Utilities , module Graphics.Blank.Utils -- ** Events , trigger , eventQueue , wait , flush , Event(..) , EventName , EventQueue -- ** Middleware , local_only ) where import Control.Concurrent import Control.Concurrent.STM import Control.Exception import Control.Monad import Control.Monad.IO.Class import Data.Aeson import Data.Aeson.Types (parse) import Data.List as L import Data.Monoid ((<>)) import qualified Data.Set as S import Data.String import qualified Data.Text as T import Data.Text (Text) import qualified Data.Text.Lazy as LT import qualified Graphics.Blank.Canvas as Canvas import Graphics.Blank.Canvas hiding (addColorStop) import Graphics.Blank.DeviceContext import Graphics.Blank.Events import qualified Graphics.Blank.Generated as Generated import Graphics.Blank.Generated hiding (fillStyle, strokeStyle, shadowColor) import qualified Graphics.Blank.JavaScript as JavaScript import Graphics.Blank.JavaScript hiding (width, height) import Graphics.Blank.Utils import qualified Network.HTTP.Types as H import Network.Wai (Middleware, responseLBS) import Network.Wai.Middleware.Local import Network.Wai.Handler.Warp -- import Network.Wai.Middleware.RequestLogger -- Used when debugging -- import Network.Wai.Middleware.Static import Paths_blank_canvas import System.IO.Unsafe (unsafePerformIO) -- import System.Mem.StableName import qualified Web.Scotty as Scotty import Web.Scotty (scottyApp, get, file) import qualified Web.Scotty.Comet as KC -- | blankCanvas is the main entry point into blank-canvas. -- A typical invocation would be -- -- >{-# LANGUAGE OverloadedStrings #-} -- >module Main where -- > -- >import Graphics.Blank -- > -- >main = blankCanvas 3000 $ \ context -> do -- > send context $ do -- > moveTo(50,50) -- > lineTo(200,100) -- > lineWidth 10 -- > strokeStyle "red" -- > stroke() -- > blankCanvas :: Options -> (DeviceContext -> IO ()) -> IO () blankCanvas opts actions = do dataDir <- getDataDir kComet <- KC.kCometPlugin locals :: TVar (S.Set Text) <- atomically $ newTVar S.empty -- print dataDir app <- scottyApp $ do -- middleware logStdoutDev sequence_ [ Scotty.middleware ware | ware <- middleware opts ] -- use the comet let kc_opts :: KC.Options kc_opts = KC.Options { KC.prefix = "/blank", KC.verbose = if debug opts then 3 else 0 } KC.connect kc_opts $ \ kc_doc -> do -- register the events we want to watch for KC.send kc_doc $ T.unlines [ "register(" <> T.pack(show nm) <> ");" | nm <- events opts ] queue <- atomically newTChan _ <- forkIO $ forever $ do val <- atomically $ readTChan $ KC.eventQueue $ kc_doc case fromJSON val of Success (event :: Event) -> do atomically $ writeTChan queue event _ -> return () let cxt0 = DeviceContext kc_doc queue 300 300 1 locals -- A bit of bootstrapping DeviceAttributes w h dpr <- send cxt0 device -- print (DeviceAttributes w h dpr) let cxt1 = cxt0 { ctx_width = w , ctx_height = h , ctx_devicePixelRatio = dpr } (actions $ cxt1) `catch` \ (e :: SomeException) -> do print ("Exception in blank-canvas application:" :: String) print e throw e get "/" $ file $ dataDir ++ "/static/index.html" get "/jquery.js" $ file $ dataDir ++ "/static/jquery.js" get "/jquery-json.js" $ file $ dataDir ++ "/static/jquery-json.js" get "/kansas-comet.js" $ file $ kComet -- There has to be a better way of doing this, using function, perhaps? get (Scotty.regex "^/(.*)$") $ do fileName :: Text <- Scotty.param "1" db <- liftIO $ atomically $ readTVar $ locals if fileName `S.member` db then do mime <- mimeTypes (T.unpack fileName) Scotty.setHeader "Content-Type" $ LT.fromStrict $ mime file $ (root opts ++ "/" ++ T.unpack fileName) else do Scotty.next return () runSettings (setPort (port opts) $ setTimeout 5 $ defaultSettings ) app -- | Sends a set of Canvas commands to the canvas. Attempts -- to common up as many commands as possible. Should not crash. send :: DeviceContext -> Canvas a -> IO a send cxt commands = send' (deviceCanvasContext cxt) commands id where sendBind :: CanvasContext -> Canvas a -> (a -> Canvas b) -> (String -> String) -> IO b sendBind c (Return a) k cmds = send' c (k a) cmds sendBind c (Bind m k1) k2 cmds = sendBind c m (\ r -> Bind (k1 r) k2) cmds sendBind c (Method cmd) k cmds = send' c (k ()) (cmds . ((showJS c ++ ".") ++) . shows cmd . (";" ++)) sendBind c (Command cmd) k cmds = send' c (k ()) (cmds . shows cmd . (";" ++)) sendBind c (Query query) k cmds = sendQuery c query k cmds sendBind c (With c' m) k cmds = send' c' (Bind m (With c . k)) cmds sendBind c MyContext k cmds = send' c (k c) cmds sendQuery :: CanvasContext -> Query a -> (a -> Canvas b) -> (String -> String) -> IO b sendQuery c query k cmds = do case query of NewImage url -> do let url' = if "/" `T.isPrefixOf` url then T.tail url else url atomically $ do db <- readTVar (localFiles cxt) writeTVar (localFiles cxt) $ S.insert url' $ db _ -> return () -- send the com uq <- atomically $ getUniq -- The query function returns a function takes the unique port number of the reply. sendToCanvas cxt (cmds . ((show query ++ "(" ++ show uq ++ "," ++ showJS c ++ ");") ++)) v <- KC.getReply (theComet cxt) uq case parse (parseQueryResult query) v of Error msg -> fail msg Success a -> do send' c (k a) id send' :: CanvasContext -> Canvas a -> (String -> String) -> IO a -- Most of these can be factored out, except return send' c (Bind m k) cmds = sendBind c m k cmds send' _ (With c m) cmds = send' c m cmds -- This is a bit of a hack send' _ (Return a) cmds = do sendToCanvas cxt cmds return a send' c cmd cmds = sendBind c cmd Return cmds local_only :: Middleware local_only = local $ responseLBS H.status403 [("Content-Type", "text/plain")] "local access only" {-# NOINLINE uniqVar #-} uniqVar :: TVar Int uniqVar = unsafePerformIO $ newTVarIO 0 getUniq :: STM Int getUniq = do u <- readTVar uniqVar writeTVar uniqVar (u + 1) return u mimeTypes :: Monad m => FilePath -> m Text mimeTypes filePath | ".jpg" `L.isSuffixOf` filePath = return "image/jpeg" | ".png" `L.isSuffixOf` filePath = return "image/png" | ".gif" `L.isSuffixOf` filePath = return "image/gif" | otherwise = fail $ "do not understand mime type for : " ++ show filePath ------------------------------------------------- -- TODO: add extra mime types data Options = Options { port :: Int -- ^ which port do we issue the blank canvas using , events :: [EventName] -- ^ which events does the canvas listen to , debug :: Bool -- ^ turn on debugging (default False) , root :: String -- ^ location of the static files (default .) , middleware :: [Middleware] -- ^ extra middleware(s) to be executed. (default [local_only]) } instance Num Options where (+) = error "no arithmetic for Blank Canvas Options" (-) = error "no arithmetic for Blank Canvas Options" (*) = error "no arithmetic for Blank Canvas Options" abs = error "no arithmetic for Blank Canvas Options" signum = error "no arithmetic for Blank Canvas Options" fromInteger n = Options { port = fromInteger n , events = [] , debug = False , root = "." , middleware = [local_only] } ------------------------------------------------- -- This is the monomorphic version, to stop "ambiguous" errors. fillStyle :: Text -> Canvas () fillStyle = Generated.fillStyle strokeStyle :: Text -> Canvas () strokeStyle = Generated.strokeStyle shadowColor :: Text -> Canvas () shadowColor = Generated.shadowColor addColorStop :: (Double, Text) -> CanvasGradient -> Canvas () addColorStop = Canvas.addColorStop height :: (Image image, Num a) => image -> a height = JavaScript.height width :: (Image image, Num a) => image -> a width = JavaScript.width