null-canvas 0.2.5 → 0.2.6
raw patch · 4 files changed
+79/−40 lines, 4 filesdep +filepathdep +split
Dependencies added: filepath, split
Files
- Graphics/Blank.hs +33/−32
- Graphics/Blank/Generated.hs +36/−1
- null-canvas.cabal +4/−2
- static/index.html +6/−5
Graphics/Blank.hs view
@@ -4,13 +4,15 @@ ( -- * Starting blank-canvas blankCanvas+ , blankCanvasMany , blankCanvasParams+ , blankCanvasParamsScotty -- * Graphics 'Context'- , Context -- abstact+ , Context -- abstract , send , events -- * Drawing pictures using the Canvas DSL- , Canvas -- abstact+ , Canvas -- abstract , module Graphics.Blank.Generated , readEvent , tryReadEvent@@ -26,16 +28,15 @@ import Control.Concurrent import Control.Monad.IO.Class (liftIO) import Control.Monad (when)-import Network.Wai.Handler.Warp (run)+import qualified Data.String import Web.Scotty as S import Network.Wai.Middleware.RequestLogger-import Network.Wai.Middleware.Rewrite import qualified Data.Text.Lazy as T-import qualified Data.Text as TS+import System.FilePath import qualified Data.Map as Map-import Data.Maybe (fromMaybe)-import Data.List (stripPrefix)+import Data.List (intercalate)+import Data.List.Split (splitOn) import Graphics.Blank.Events import Graphics.Blank.Context@@ -59,18 +60,23 @@ -- > stroke() -- > - blankCanvas :: Int -> (Context -> IO ()) -> IO ()-blankCanvas port actions = do- dataDir <- getDataDir- blankCanvasParams port actions dataDir False Nothing+blankCanvas port app = blankCanvasMany port [("",app)] --- | similar to blankCanvas but takes extra dataDir, performLogging, extraPathElements (to be stripped) args-blankCanvasParams :: Int -> (Context -> IO ()) -> FilePath -> Bool -> Maybe [TS.Text] -> IO ()-blankCanvasParams port actions dataDir performLogging extraPathElements = do- let performRewrite = extraPathElements /= Nothing- extraPath = fromMaybe [] extraPathElements+blankCanvasParams :: Int -> (Context -> IO ()) -> FilePath -> Bool -> String -> IO ()+blankCanvasParams port app dataDir performLogging pathPrefix = + scotty port =<< blankCanvasParamsScotty app dataDir performLogging pathPrefix +-- | launch multiple canvas apps, each with a prefix, like `/myprefix/foo/bar`+blankCanvasMany :: Int -> [(String, (Context -> IO ()))] -> IO ()+blankCanvasMany port apps = do+ dataDir <- getDataDir+ canvases <- mapM (\ (prefix,app) -> blankCanvasParamsScotty app dataDir False prefix) apps+ scotty port (sequence_ canvases) ++-- | parametrised version of blankCanvas, also returns ScottyM application instead of running a server. use 'scotty' to run it.+blankCanvasParamsScotty :: (Context -> IO ()) -> FilePath -> Bool -> String -> IO (ScottyM ())+blankCanvasParamsScotty actions dataDir performLogging pathPrefix = do uVar <- newMVar 0 let getUniq :: IO Int getUniq = do@@ -91,26 +97,23 @@ _ <- forkIO $ actions cxt return uq - app <- scottyApp $ do- when performRewrite (middleware (rewrite (\ pathOrig headers -> do- print (pathOrig, headers, extraPath)- let fixed = stripPrefix extraPath pathOrig- print fixed- return (fromMaybe pathOrig fixed))))- when performLogging (middleware logStdoutDev)+ bareIndex <- readFile (dataDir </> "static" </> "index.html")+ let fixedIndex = T.pack $ intercalate pathPrefix $ splitOn "XXX_URL_PREFIX_XXX" bareIndex --- middleware $ staticRoot $ TS.pack $ (dataDir ++ "/static")+ return $ do+ when performLogging (middleware logStdoutDev)+ let addPrefix lit = Data.String.fromString (pathPrefix ++ lit) - 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 (addPrefix "/") $ html fixedIndex+ get (addPrefix "/jquery.js") $ file $ dataDir </> "static" </> "jquery.js"+ get (addPrefix "/jquery-json.js") $ file $ dataDir </> "static" </> "jquery-json.js" - post "/start" $ do+ post (addPrefix "/start") $ do req <- jsonData uq <- liftIO $ newContext req text (T.pack $ "session = " ++ show uq ++ ";redraw();") - post "/event/:num" $ do+ post (addPrefix "/event/:num") $ do header "Cache-Control" "max-age=0, no-cache, private, no-store, must-revalidate" num <- param "num" NamedEvent nm event <- jsonData@@ -124,7 +127,7 @@ Just var -> do liftIO $ writeEventQueue var event json () - get "/canvas/:num" $ do+ get (addPrefix "/canvas/:num") $ do header "Cache-Control" "max-age=0, no-cache, private, no-store, must-revalidate" -- do something and return a new list of commands to the client num <- param "num"@@ -145,8 +148,6 @@ case Map.lookup num db of Nothing -> text (T.pack $ "alert('/canvas/, can not find " ++ show num ++ "');") Just (Context _ pic _ _) -> tryPicture pic 10-- run port app -- | Sends a set of Canvas commands to the canvas. Attempts -- to common up as many commands as possible.
Graphics/Blank/Generated.hs view
@@ -37,94 +37,129 @@ -- DSL +-- | see <http://www.w3schools.com/tags/canvas_arc.asp> arc :: (Float,Float,Float,Float,Float,Bool) -> Canvas () arc = Command . Arc +-- | see <http://www.w3schools.com/tags/canvas_beginpath.asp> beginPath :: Canvas () beginPath = Command BeginPath +-- | see <http://www.w3schools.com/tags/canvas_beziercurveto.asp> bezierCurveTo :: (Float,Float,Float,Float,Float,Float) -> Canvas () bezierCurveTo = Command . BezierCurveTo +-- | see <http://www.w3schools.com/tags/canvas_clearrect.asp> clearRect :: (Float,Float,Float,Float) -> Canvas () clearRect = Command . ClearRect +-- | see <http://www.w3schools.com/tags/canvas_closepath.asp> closePath :: Canvas () closePath = Command ClosePath --- | sends command (JS) unchanged +-- | sends command (JS) unchanged. useful for extending this library with functionality it doesn't currently have. example: +--+-- > custom $ unlines $ [+-- > "var grd=c.createRadialGradient(0,0,3,20,20,10); "+-- > ,"grd.addColorStop(0,\"white\");"+-- > ,"grd.addColorStop(1,\"red\");"+-- > ,"c.fillStyle=grd;"] custom :: String -> Canvas () custom = Command . Custom +-- | see <http://www.w3schools.com/tags/canvas_fill.asp> fill :: Canvas () fill = Command Fill +-- | see <http://www.w3schools.com/tags/canvas_fillrect.asp> fillRect :: (Float,Float,Float,Float) -> Canvas () fillRect = Command . FillRect +-- | see <http://www.w3schools.com/tags/canvas_fillstyle.asp> fillStyle :: String -> Canvas () fillStyle = Command . FillStyle +-- | see <http://www.w3schools.com/tags/canvas_filltext.asp> fillText :: (String,Float,Float) -> Canvas () fillText = Command . FillText +-- | see <http://www.w3schools.com/tags/canvas_font.asp> font :: String -> Canvas () font = Command . Font +-- | see <http://www.w3schools.com/tags/canvas_globalalpha.asp> globalAlpha :: Float -> Canvas () globalAlpha = Command . GlobalAlpha +-- | see <http://www.w3schools.com/tags/canvas_linecap.asp> lineCap :: String -> Canvas () lineCap = Command . LineCap +-- | see <http://www.w3schools.com/tags/canvas_linejoin.asp> lineJoin :: String -> Canvas () lineJoin = Command . LineJoin +-- | see <http://www.w3schools.com/tags/canvas_lineto.asp> lineTo :: (Float,Float) -> Canvas () lineTo = Command . LineTo +-- | see <http://www.w3schools.com/tags/canvas_linewidth.asp> lineWidth :: Float -> Canvas () lineWidth = Command . LineWidth +-- | see <http://www.w3schools.com/tags/canvas_miterlimit.asp> miterLimit :: Float -> Canvas () miterLimit = Command . MiterLimit +-- | see <http://www.w3schools.com/tags/canvas_moveto.asp> moveTo :: (Float,Float) -> Canvas () moveTo = Command . MoveTo +-- | see bottom of <http://www.w3schools.com/tags/ref_canvas.asp> restore :: Canvas () restore = Command Restore +-- | see <http://www.w3schools.com/tags/canvas_rotate.asp> rotate :: Float -> Canvas () rotate = Command . Rotate +-- | <http://www.w3schools.com/tags/canvas_scale.asp> scale :: (Float,Float) -> Canvas () scale = Command . Scale +-- | see bottom of <http://www.w3schools.com/tags/ref_canvas.asp> save :: Canvas () save = Command Save +-- | see <http://www.w3schools.com/tags/canvas_stroke.asp> stroke :: Canvas () stroke = Command Stroke +-- | see <http://www.w3schools.com/tags/canvas_strokerect.asp> strokeRect :: (Float,Float,Float,Float) -> Canvas () strokeRect = Command . StrokeRect +-- | see <http://www.w3schools.com/tags/canvas_stroketext.asp> strokeText :: (String,Float,Float) -> Canvas () strokeText = Command . StrokeText +-- | see <http://www.w3schools.com/tags/canvas_strokestyle.asp> strokeStyle :: String -> Canvas () strokeStyle = Command . StrokeStyle +-- | see <http://www.w3schools.com/tags/canvas_textalign.asp> textAlign :: String -> Canvas () textAlign = Command . TextAlign +-- | see <http://www.w3schools.com/tags/canvas_textbaseline.asp> textBaseline :: String -> Canvas () textBaseline = Command . TextBaseline +-- | see <http://www.w3schools.com/tags/canvas_transform.asp> transform :: (Float,Float,Float,Float,Float,Float) -> Canvas () transform = Command . Transform +-- | see <http://www.w3schools.com/tags/canvas_translate.asp> translate :: (Float,Float) -> Canvas () translate = Command . Translate
null-canvas.cabal view
@@ -1,5 +1,5 @@ Name: null-canvas-Version: 0.2.5+Version: 0.2.6 Synopsis: HTML5 Canvas Graphics Library - forked Blank Canvas Description: A Haskell port of the HTML5 Canvas API. blank-canvas works by providing a web service that@@ -48,7 +48,9 @@ transformers >= 0.2.2, wai-extra == 1.3.*, warp >= 1.3.1 && < 1.4,- stm == 2.*+ stm == 2.*,+ split ,+ filepath GHC-options: -Wall -fno-warn-orphans
static/index.html view
@@ -1,13 +1,14 @@ <html> <head> <title>Null Canvas</title>- <script type="text/javascript" src="jquery.js"></script>- <script type="text/javascript" src="jquery-json.js"></script>+ <script type="text/javascript" src="XXX_URL_PREFIX_XXX/jquery.js"></script>+ <script type="text/javascript" src="XXX_URL_PREFIX_XXX/jquery-json.js"></script> </head> <body style="padding: 0px; margin: 0px; border:0px"> <div id="canvas"></div> <script type="text/javascript"> var session = 0; // global session number+ var url_prefix = "XXX_URL_PREFIX_XXX"; // url prefix, updated on runtime function getContext() { var canvas = document.getElementById("canvas"); if (canvas.getContext) {@@ -17,7 +18,7 @@ } function register(name,mysession) { $(document).bind(name,function (e){- $.ajax({ url: "/event/" + mysession,+ $.ajax({ url: url_prefix + "/event/" + mysession, type: "POST", data: $.toJSON([name,e.which,e.pageX, e.pageY]), contentType: "application/json; charset=utf-8",@@ -25,7 +26,7 @@ }); } function redraw() {- $.ajax({ url: "/canvas/" + session,+ $.ajax({ url: url_prefix + "/canvas/" + session, type: "GET", dataType: "script", success: function success() {@@ -44,7 +45,7 @@ '" style="border: blue solid 0px; padding: 0px; margin: 0px"></canvas>'); // start the server-side- $.ajax({ url: "/start",+ $.ajax({ url: url_prefix + "/start", type: "POST", contentType: "application/json; charset=utf-8", data: $.toJSON([w,h]),