diff --git a/Graphics/Blank.hs b/Graphics/Blank.hs --- a/Graphics/Blank.hs +++ b/Graphics/Blank.hs @@ -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. diff --git a/Graphics/Blank/Generated.hs b/Graphics/Blank/Generated.hs --- a/Graphics/Blank/Generated.hs +++ b/Graphics/Blank/Generated.hs @@ -37,94 +37,129 @@ -- DSL +-- | see arc :: (Float,Float,Float,Float,Float,Bool) -> Canvas () arc = Command . Arc +-- | see beginPath :: Canvas () beginPath = Command BeginPath +-- | see bezierCurveTo :: (Float,Float,Float,Float,Float,Float) -> Canvas () bezierCurveTo = Command . BezierCurveTo +-- | see clearRect :: (Float,Float,Float,Float) -> Canvas () clearRect = Command . ClearRect +-- | see 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 fill :: Canvas () fill = Command Fill +-- | see fillRect :: (Float,Float,Float,Float) -> Canvas () fillRect = Command . FillRect +-- | see fillStyle :: String -> Canvas () fillStyle = Command . FillStyle +-- | see fillText :: (String,Float,Float) -> Canvas () fillText = Command . FillText +-- | see font :: String -> Canvas () font = Command . Font +-- | see globalAlpha :: Float -> Canvas () globalAlpha = Command . GlobalAlpha +-- | see lineCap :: String -> Canvas () lineCap = Command . LineCap +-- | see lineJoin :: String -> Canvas () lineJoin = Command . LineJoin +-- | see lineTo :: (Float,Float) -> Canvas () lineTo = Command . LineTo +-- | see lineWidth :: Float -> Canvas () lineWidth = Command . LineWidth +-- | see miterLimit :: Float -> Canvas () miterLimit = Command . MiterLimit +-- | see moveTo :: (Float,Float) -> Canvas () moveTo = Command . MoveTo +-- | see bottom of restore :: Canvas () restore = Command Restore +-- | see rotate :: Float -> Canvas () rotate = Command . Rotate +-- | scale :: (Float,Float) -> Canvas () scale = Command . Scale +-- | see bottom of save :: Canvas () save = Command Save +-- | see stroke :: Canvas () stroke = Command Stroke +-- | see strokeRect :: (Float,Float,Float,Float) -> Canvas () strokeRect = Command . StrokeRect +-- | see strokeText :: (String,Float,Float) -> Canvas () strokeText = Command . StrokeText +-- | see strokeStyle :: String -> Canvas () strokeStyle = Command . StrokeStyle +-- | see textAlign :: String -> Canvas () textAlign = Command . TextAlign +-- | see textBaseline :: String -> Canvas () textBaseline = Command . TextBaseline +-- | see transform :: (Float,Float,Float,Float,Float,Float) -> Canvas () transform = Command . Transform +-- | see translate :: (Float,Float) -> Canvas () translate = Command . Translate diff --git a/null-canvas.cabal b/null-canvas.cabal --- a/null-canvas.cabal +++ b/null-canvas.cabal @@ -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 diff --git a/static/index.html b/static/index.html --- a/static/index.html +++ b/static/index.html @@ -1,13 +1,14 @@ Null Canvas - - + +