{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Graphics.Blank
(
blankCanvas
, Options(..)
, DeviceContext
, send
, Canvas
, height
, width
, toDataURL
, save
, restore
, scale
, rotate
, translate
, transform
, setTransform
, Image
, drawImage
, globalAlpha
, globalCompositeOperation
, lineWidth
, lineCap
, lineJoin
, miterLimit
, LineEndCap(..)
, butt
, square
, LineJoinCorner(..)
, bevel
, miter
, strokeStyle
, fillStyle
, shadowOffsetX
, shadowOffsetY
, shadowBlur
, shadowColor
, createLinearGradient
, createRadialGradient
, createPattern
, addColorStop
, RepeatDirection(..)
, repeat_
, repeatX
, repeatY
, noRepeat
, CanvasGradient
, CanvasPattern
, beginPath
, closePath
, fill
, stroke
, clip
, moveTo
, lineTo
, quadraticCurveTo
, bezierCurveTo
, arcTo
, arc
, rect
, isPointInPath
, font
, textAlign
, textBaseline
, fillText
, strokeText
, measureText
, TextAnchorAlignment(..)
, start
, end
, center
, left
, right
, TextBaselineAlignment(..)
, top
, hanging
, middle
, alphabetic
, ideographic
, bottom
, TextMetrics(..)
, clearRect
, fillRect
, strokeRect
, getImageData
, putImageData
, ImageData(..)
, Alpha
, Degrees
, Interval
, Percentage
, Radians
, RoundProperty(..)
, newImage
, CanvasImage
, newAudio
, CanvasAudio
, devicePixelRatio
, CanvasContext
, newCanvas
, with
, myCanvasContext
, deviceCanvasContext
, sync
, console_log
, eval
, JSArg(..)
, module Graphics.Blank.Utils
, trigger
, eventQueue
, wait
, flush
, Event(..)
, EventName
, EventQueue
, cursor
, local_only
) where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad (forever)
import Control.Monad.IO.Class
import Data.Aeson (Result(..), fromJSON)
import Data.Aeson.Types (parse)
import qualified Data.Map as M (lookup)
import qualified Data.Set as S
import qualified Data.Text as T
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Text.Lazy as LT
import qualified Graphics.Blank.Canvas as Canvas
import Graphics.Blank.Canvas hiding (addColorStop, cursor)
import Graphics.Blank.DeviceContext
import Graphics.Blank.Events
import qualified Graphics.Blank.Generated as Generated
import Graphics.Blank.Generated hiding (fillStyle, font, strokeStyle, shadowColor)
import qualified Graphics.Blank.JavaScript as JavaScript
import Graphics.Blank.JavaScript hiding (width, height)
import Graphics.Blank.Types
import Graphics.Blank.Utils
import qualified Network.HTTP.Types as H
import Network.Mime (defaultMimeMap, fileNameExtensions)
import Network.Wai (Middleware, responseLBS)
import Network.Wai.Middleware.Local
import Network.Wai.Handler.Warp
import Paths_blank_canvas
import Prelude.Compat
import System.IO.Unsafe (unsafePerformIO)
import TextShow (Builder, showb, showt, singleton)
import qualified Web.Scotty as Scotty
import Web.Scotty (scottyApp, get, file)
import qualified Web.Scotty.Comet as KC
blankCanvas :: Options -> (DeviceContext -> IO ()) -> IO ()
blankCanvas :: Options -> (DeviceContext -> IO ()) -> IO ()
blankCanvas Options
opts DeviceContext -> IO ()
actions = do
[Char]
dataDir <- IO [Char]
getDataDir
[Char]
kComet <- IO [Char]
KC.kCometPlugin
TVar (Set Text)
locals :: TVar (S.Set Text) <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. a -> STM (TVar a)
newTVar forall a. Set a
S.empty
let kc_opts :: KC.Options
kc_opts :: Options
kc_opts = KC.Options { prefix :: [Char]
KC.prefix = [Char]
"/blank", verbose :: Int
KC.verbose = if Options -> Bool
debug Options
opts then Int
3 else Int
0 }
ScottyM ()
connectApp <- Options -> (Document -> IO ()) -> IO (ScottyM ())
KC.connect Options
kc_opts forall a b. (a -> b) -> a -> b
$ \ Document
kc_doc -> do
Document -> Text -> IO ()
KC.send Document
kc_doc forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
[ Text
"register(" forall a. Semigroup a => a -> a -> a
<> forall a. TextShow a => a -> Text
showt Text
nm forall a. Semigroup a => a -> a -> a
<> Text
");"
| Text
nm <- Options -> [Text]
events Options
opts
]
TChan Event
queue <- forall a. STM a -> IO a
atomically forall a. STM (TChan a)
newTChan
ThreadId
_ <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
Value
val <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> STM a
readTChan forall a b. (a -> b) -> a -> b
$ Document -> TChan Value
KC.eventQueue forall a b. (a -> b) -> a -> b
$ Document
kc_doc
case forall a. FromJSON a => Value -> Result a
fromJSON Value
val of
Success (Event
event :: Event) -> do
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
writeTChan TChan Event
queue Event
event
Result Event
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
let cxt0 :: DeviceContext
cxt0 = Document
-> TChan Event
-> Int
-> Int
-> Double
-> TVar (Set Text)
-> Bool
-> DeviceContext
DeviceContext Document
kc_doc TChan Event
queue Int
300 Int
300 Double
1 TVar (Set Text)
locals Bool
False
DeviceAttributes Int
w Int
h Double
dpr <- forall a. DeviceContext -> Canvas a -> IO a
send DeviceContext
cxt0 Canvas DeviceAttributes
device
let cxt1 :: DeviceContext
cxt1 = DeviceContext
cxt0
{ ctx_width :: Int
ctx_width = Int
w
, ctx_height :: Int
ctx_height = Int
h
, ctx_devicePixelRatio :: Double
ctx_devicePixelRatio = Double
dpr
, weakRemoteMonad :: Bool
weakRemoteMonad = Options -> Bool
weak Options
opts
}
(DeviceContext -> IO ()
actions forall a b. (a -> b) -> a -> b
$ DeviceContext
cxt1) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \ (SomeException
e :: SomeException) -> do
forall a. Show a => a -> IO ()
print ([Char]
"Exception in blank-canvas application:" :: String)
forall a. Show a => a -> IO ()
print SomeException
e
forall a e. Exception e => e -> a
throw SomeException
e
Application
app <- ScottyM () -> IO Application
scottyApp forall a b. (a -> b) -> a -> b
$ do
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ Middleware -> ScottyM ()
Scotty.middleware Middleware
ware
| Middleware
ware <- Options -> [Middleware]
middleware Options
opts
]
ScottyM ()
connectApp
RoutePattern -> ActionM () -> ScottyM ()
get RoutePattern
"/" forall a b. (a -> b) -> a -> b
$ [Char] -> ActionM ()
file forall a b. (a -> b) -> a -> b
$ [Char]
dataDir forall a. [a] -> [a] -> [a]
++ [Char]
"/static/index.html"
RoutePattern -> ActionM () -> ScottyM ()
get RoutePattern
"/jquery.js" forall a b. (a -> b) -> a -> b
$ [Char] -> ActionM ()
file forall a b. (a -> b) -> a -> b
$ [Char]
dataDir forall a. [a] -> [a] -> [a]
++ [Char]
"/static/jquery.js"
RoutePattern -> ActionM () -> ScottyM ()
get RoutePattern
"/jquery-json.js" forall a b. (a -> b) -> a -> b
$ [Char] -> ActionM ()
file forall a b. (a -> b) -> a -> b
$ [Char]
dataDir forall a. [a] -> [a] -> [a]
++ [Char]
"/static/jquery-json.js"
RoutePattern -> ActionM () -> ScottyM ()
get RoutePattern
"/kansas-comet.js" forall a b. (a -> b) -> a -> b
$ [Char] -> ActionM ()
file forall a b. (a -> b) -> a -> b
$ [Char]
kComet
RoutePattern -> ActionM () -> ScottyM ()
get ([Char] -> RoutePattern
Scotty.regex [Char]
"^/(.*)$") forall a b. (a -> b) -> a -> b
$ do
Text
fileName :: Text <- Text -> ActionM Text
captureParam Text
"1"
Set Text
db <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> STM a
readTVar forall a b. (a -> b) -> a -> b
$ TVar (Set Text)
locals
if Text
fileName forall a. Ord a => a -> Set a -> Bool
`S.member` Set Text
db
then do
let mime :: Text
mime = Text -> Text
mimeType Text
fileName
Text -> Text -> ActionM ()
Scotty.setHeader Text
"Content-Type" forall a b. (a -> b) -> a -> b
$ Text -> Text
LT.fromStrict forall a b. (a -> b) -> a -> b
$ Text
mime
[Char] -> ActionM ()
file forall a b. (a -> b) -> a -> b
$ (Options -> [Char]
root Options
opts forall a. [a] -> [a] -> [a]
++ [Char]
"/" forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
fileName)
else do
ActionM ()
Scotty.next
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Settings -> Application -> IO ()
runSettings (Int -> Settings -> Settings
setPort (Options -> Int
port Options
opts)
forall a b. (a -> b) -> a -> b
$ Int -> Settings -> Settings
setTimeout Int
5
forall a b. (a -> b) -> a -> b
$ Settings
defaultSettings
) Application
app
where
#if MIN_VERSION_scotty(0,20,0)
captureParam :: Text -> ActionM Text
captureParam = forall a. Parsable a => Text -> ActionM a
Scotty.captureParam
#else
captureParam = Scotty.param
#endif
send :: DeviceContext -> Canvas a -> IO a
send :: forall a. DeviceContext -> Canvas a -> IO a
send DeviceContext
_ (Return a
a) = forall (m :: * -> *) a. Monad m => a -> m a
return a
a
send DeviceContext
cxt (Bind Canvas a1
m a1 -> Canvas a
k) | DeviceContext -> Bool
weakRemoteMonad DeviceContext
cxt = forall a. DeviceContext -> Canvas a -> IO a
send DeviceContext
cxt Canvas a1
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. DeviceContext -> Canvas a -> IO a
send DeviceContext
cxt forall b c a. (b -> c) -> (a -> b) -> a -> c
. a1 -> Canvas a
k
send DeviceContext
cxt (With CanvasContext
c (Bind Canvas a1
m a1 -> Canvas a
k)) | DeviceContext -> Bool
weakRemoteMonad DeviceContext
cxt = forall a. DeviceContext -> Canvas a -> IO a
send DeviceContext
cxt (forall a. CanvasContext -> Canvas a -> Canvas a
With CanvasContext
c Canvas a1
m) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. DeviceContext -> Canvas a -> IO a
send DeviceContext
cxt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. CanvasContext -> Canvas a -> Canvas a
With CanvasContext
c forall b c a. (b -> c) -> (a -> b) -> a -> c
. a1 -> Canvas a
k
send DeviceContext
cxt (With CanvasContext
_ (With CanvasContext
c Canvas a
m)) | DeviceContext -> Bool
weakRemoteMonad DeviceContext
cxt = forall a. DeviceContext -> Canvas a -> IO a
send DeviceContext
cxt (forall a. CanvasContext -> Canvas a -> Canvas a
With CanvasContext
c Canvas a
m)
send DeviceContext
cxt Canvas a
commands = forall a. CanvasContext -> Canvas a -> Builder -> IO a
send' (DeviceContext -> CanvasContext
deviceCanvasContext DeviceContext
cxt) Canvas a
commands forall a. Monoid a => a
mempty
where
sendBind :: CanvasContext -> Canvas a -> (a -> Canvas b) -> Builder -> IO b
sendBind :: forall a b.
CanvasContext -> Canvas a -> (a -> Canvas b) -> Builder -> IO b
sendBind CanvasContext
c (Return a
a) a -> Canvas b
k Builder
cmds = forall a. CanvasContext -> Canvas a -> Builder -> IO a
send' CanvasContext
c (a -> Canvas b
k a
a) Builder
cmds
sendBind CanvasContext
c (Bind Canvas a1
m a1 -> Canvas a
k1) a -> Canvas b
k2 Builder
cmds = forall a b.
CanvasContext -> Canvas a -> (a -> Canvas b) -> Builder -> IO b
sendBind CanvasContext
c Canvas a1
m (\ a1
r -> forall a1 a. Canvas a1 -> (a1 -> Canvas a) -> Canvas a
Bind (a1 -> Canvas a
k1 a1
r) a -> Canvas b
k2) Builder
cmds
sendBind CanvasContext
c (Method Method
cmd) a -> Canvas b
k Builder
cmds = forall a. CanvasContext -> Canvas a -> Builder -> IO a
send' CanvasContext
c (a -> Canvas b
k ()) (Builder
cmds forall a. Semigroup a => a -> a -> a
<> CanvasContext -> Builder
jsCanvasContext CanvasContext
c forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
'.' forall a. Semigroup a => a -> a -> a
<> forall a. TextShow a => a -> Builder
showb Method
cmd forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
';')
sendBind CanvasContext
c (Command Command
cmd) a -> Canvas b
k Builder
cmds = forall a. CanvasContext -> Canvas a -> Builder -> IO a
send' CanvasContext
c (a -> Canvas b
k ()) (Builder
cmds forall a. Semigroup a => a -> a -> a
<> forall a. TextShow a => a -> Builder
showb Command
cmd forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
';')
sendBind CanvasContext
c (Function Function a
func) a -> Canvas b
k Builder
cmds = forall a b.
CanvasContext -> Function a -> (a -> Canvas b) -> Builder -> IO b
sendFunc CanvasContext
c Function a
func a -> Canvas b
k Builder
cmds
sendBind CanvasContext
c (Query Query a
query) a -> Canvas b
k Builder
cmds = forall a b.
CanvasContext -> Query a -> (a -> Canvas b) -> Builder -> IO b
sendQuery CanvasContext
c Query a
query a -> Canvas b
k Builder
cmds
sendBind CanvasContext
c (With CanvasContext
c' Canvas a
m) a -> Canvas b
k Builder
cmds = forall a. CanvasContext -> Canvas a -> Builder -> IO a
send' CanvasContext
c' (forall a1 a. Canvas a1 -> (a1 -> Canvas a) -> Canvas a
Bind Canvas a
m (forall a. CanvasContext -> Canvas a -> Canvas a
With CanvasContext
c forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Canvas b
k)) Builder
cmds
sendBind CanvasContext
c Canvas a
MyContext a -> Canvas b
k Builder
cmds = forall a. CanvasContext -> Canvas a -> Builder -> IO a
send' CanvasContext
c (a -> Canvas b
k CanvasContext
c) Builder
cmds
sendFunc :: CanvasContext -> Function a -> (a -> Canvas b) -> Builder -> IO b
sendFunc :: forall a b.
CanvasContext -> Function a -> (a -> Canvas b) -> Builder -> IO b
sendFunc CanvasContext
c q :: Function a
q@(CreateLinearGradient (Double, Double, Double, Double)
_) a -> Canvas b
k Builder
cmds = forall a b.
CanvasContext
-> Function a -> (CanvasGradient -> Canvas b) -> Builder -> IO b
sendGradient CanvasContext
c Function a
q a -> Canvas b
k Builder
cmds
sendFunc CanvasContext
c q :: Function a
q@(CreateRadialGradient (Double, Double, Double, Double, Double, Double)
_) a -> Canvas b
k Builder
cmds = forall a b.
CanvasContext
-> Function a -> (CanvasGradient -> Canvas b) -> Builder -> IO b
sendGradient CanvasContext
c Function a
q a -> Canvas b
k Builder
cmds
sendFunc CanvasContext
c q :: Function a
q@(CreatePattern (image, RepeatDirection)
_) a -> Canvas b
k Builder
cmds = forall a b.
CanvasContext
-> Function a -> (CanvasPattern -> Canvas b) -> Builder -> IO b
sendPattern CanvasContext
c Function a
q a -> Canvas b
k Builder
cmds
sendGradient :: CanvasContext -> Function a -> (CanvasGradient -> Canvas b) -> Builder -> IO b
sendGradient :: forall a b.
CanvasContext
-> Function a -> (CanvasGradient -> Canvas b) -> Builder -> IO b
sendGradient CanvasContext
c Function a
q CanvasGradient -> Canvas b
k Builder
cmds = do
Int
gId <- forall a. STM a -> IO a
atomically STM Int
getUniq
forall a. CanvasContext -> Canvas a -> Builder -> IO a
send' CanvasContext
c (CanvasGradient -> Canvas b
k forall a b. (a -> b) -> a -> b
$ Int -> CanvasGradient
CanvasGradient Int
gId) forall a b. (a -> b) -> a -> b
$ Builder
cmds forall a. Semigroup a => a -> a -> a
<> Builder
"var gradient_"
forall a. Semigroup a => a -> a -> a
<> forall a. TextShow a => a -> Builder
showb Int
gId forall a. Semigroup a => a -> a -> a
<> Builder
" = " forall a. Semigroup a => a -> a -> a
<> CanvasContext -> Builder
jsCanvasContext CanvasContext
c
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
'.' forall a. Semigroup a => a -> a -> a
<> forall a. TextShow a => a -> Builder
showb Function a
q forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
';'
sendPattern :: CanvasContext -> Function a -> (CanvasPattern -> Canvas b) -> Builder -> IO b
sendPattern :: forall a b.
CanvasContext
-> Function a -> (CanvasPattern -> Canvas b) -> Builder -> IO b
sendPattern CanvasContext
c Function a
q CanvasPattern -> Canvas b
k Builder
cmds = do
Int
pId <- forall a. STM a -> IO a
atomically STM Int
getUniq
forall a. CanvasContext -> Canvas a -> Builder -> IO a
send' CanvasContext
c (CanvasPattern -> Canvas b
k forall a b. (a -> b) -> a -> b
$ Int -> CanvasPattern
CanvasPattern Int
pId) forall a b. (a -> b) -> a -> b
$ Builder
cmds forall a. Semigroup a => a -> a -> a
<> Builder
"var pattern_"
forall a. Semigroup a => a -> a -> a
<> forall a. TextShow a => a -> Builder
showb Int
pId forall a. Semigroup a => a -> a -> a
<> Builder
" = " forall a. Semigroup a => a -> a -> a
<> CanvasContext -> Builder
jsCanvasContext CanvasContext
c
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
'.' forall a. Semigroup a => a -> a -> a
<> forall a. TextShow a => a -> Builder
showb Function a
q forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
';'
fileQuery :: Text -> IO ()
fileQuery :: Text -> IO ()
fileQuery Text
url = do
let url' :: Text
url' = if Text
"/" Text -> Text -> Bool
`T.isPrefixOf` Text
url then Text -> Text
T.tail Text
url else Text
url
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
Set Text
db <- forall a. TVar a -> STM a
readTVar (DeviceContext -> TVar (Set Text)
localFiles DeviceContext
cxt)
forall a. TVar a -> a -> STM ()
writeTVar (DeviceContext -> TVar (Set Text)
localFiles DeviceContext
cxt) forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Set a
S.insert Text
url' forall a b. (a -> b) -> a -> b
$ Set Text
db
sendQuery :: CanvasContext -> Query a -> (a -> Canvas b) -> Builder -> IO b
sendQuery :: forall a b.
CanvasContext -> Query a -> (a -> Canvas b) -> Builder -> IO b
sendQuery CanvasContext
c Query a
query a -> Canvas b
k Builder
cmds = do
case Query a
query of
NewImage Text
url -> Text -> IO ()
fileQuery Text
url
NewAudio Text
url -> Text -> IO ()
fileQuery Text
url
Query a
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Int
uq <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ STM Int
getUniq
DeviceContext -> Builder -> IO ()
sendToCanvas DeviceContext
cxt forall a b. (a -> b) -> a -> b
$ Builder
cmds forall a. Semigroup a => a -> a -> a
<> forall a. TextShow a => a -> Builder
showb Query a
query forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
'(' forall a. Semigroup a => a -> a -> a
<> forall a. TextShow a => a -> Builder
showb Int
uq forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
',' forall a. Semigroup a => a -> a -> a
<> CanvasContext -> Builder
jsCanvasContext CanvasContext
c forall a. Semigroup a => a -> a -> a
<> Builder
");"
Value
v <- Document -> Int -> IO Value
KC.getReply (DeviceContext -> Document
theComet DeviceContext
cxt) Int
uq
case forall a b. (a -> Parser b) -> a -> Result b
parse (forall a. Query a -> Value -> Parser a
parseQueryResult Query a
query) Value
v of
Error [Char]
msg -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
msg
Success a
a -> forall a. CanvasContext -> Canvas a -> Builder -> IO a
send' CanvasContext
c (a -> Canvas b
k a
a) forall a. Monoid a => a
mempty
send' :: CanvasContext -> Canvas a -> Builder -> IO a
send' :: forall a. CanvasContext -> Canvas a -> Builder -> IO a
send' CanvasContext
c (Bind Canvas a1
m a1 -> Canvas a
k) Builder
cmds = forall a b.
CanvasContext -> Canvas a -> (a -> Canvas b) -> Builder -> IO b
sendBind CanvasContext
c Canvas a1
m a1 -> Canvas a
k Builder
cmds
send' CanvasContext
_ (With CanvasContext
c Canvas a
m) Builder
cmds = forall a. CanvasContext -> Canvas a -> Builder -> IO a
send' CanvasContext
c Canvas a
m Builder
cmds
send' CanvasContext
_ (Return a
a) Builder
cmds = do
DeviceContext -> Builder -> IO ()
sendToCanvas DeviceContext
cxt Builder
cmds
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
send' CanvasContext
c Canvas a
cmd Builder
cmds = forall a b.
CanvasContext -> Canvas a -> (a -> Canvas b) -> Builder -> IO b
sendBind CanvasContext
c Canvas a
cmd forall a. a -> Canvas a
Return Builder
cmds
local_only :: Middleware
local_only :: Middleware
local_only = Response -> Middleware
local forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
H.status403 [(HeaderName
"Content-Type", ByteString
"text/plain")] ByteString
"local access only"
{-# NOINLINE uniqVar #-}
uniqVar :: TVar Int
uniqVar :: TVar Int
uniqVar = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (TVar a)
newTVarIO Int
0
getUniq :: STM Int
getUniq :: STM Int
getUniq = do
Int
u <- forall a. TVar a -> STM a
readTVar TVar Int
uniqVar
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
uniqVar (Int
u forall a. Num a => a -> a -> a
+ Int
1)
forall (m :: * -> *) a. Monad m => a -> m a
return Int
u
mimeType :: Text -> Text
mimeType :: Text -> Text
mimeType Text
filePath = [Text] -> Text
go forall a b. (a -> b) -> a -> b
$ Text -> [Text]
fileNameExtensions Text
filePath
where
go :: [Text] -> Text
go [] = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"do not understand mime type for : " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Text
filePath
go (Text
e:[Text]
es) = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
e MimeMap
defaultMimeMap of
Maybe ByteString
Nothing -> [Text] -> Text
go [Text]
es
Just ByteString
mt -> ByteString -> Text
decodeUtf8 ByteString
mt
data Options = Options
{ Options -> Int
port :: Int
, Options -> [Text]
events :: [EventName]
, Options -> Bool
debug :: Bool
, Options -> [Char]
root :: String
, Options -> [Middleware]
middleware :: [Middleware]
, Options -> Bool
weak :: Bool
}
instance Num Options where
+ :: Options -> Options -> Options
(+) = forall a. HasCallStack => [Char] -> a
error [Char]
"no arithmetic for Blank Canvas Options"
(-) = forall a. HasCallStack => [Char] -> a
error [Char]
"no arithmetic for Blank Canvas Options"
* :: Options -> Options -> Options
(*) = forall a. HasCallStack => [Char] -> a
error [Char]
"no arithmetic for Blank Canvas Options"
abs :: Options -> Options
abs = forall a. HasCallStack => [Char] -> a
error [Char]
"no arithmetic for Blank Canvas Options"
signum :: Options -> Options
signum = forall a. HasCallStack => [Char] -> a
error [Char]
"no arithmetic for Blank Canvas Options"
fromInteger :: Integer -> Options
fromInteger Integer
n = Options { port :: Int
port = forall a. Num a => Integer -> a
fromInteger Integer
n
, events :: [Text]
events = []
, debug :: Bool
debug = Bool
False
, root :: [Char]
root = [Char]
"."
, middleware :: [Middleware]
middleware = [Middleware
local_only]
, weak :: Bool
weak = Bool
False
}
fillStyle :: Text -> Canvas ()
fillStyle :: Text -> Canvas ()
fillStyle = forall style. Style style => style -> Canvas ()
Generated.fillStyle
font :: Text -> Canvas ()
font :: Text -> Canvas ()
font = forall canvasFont. CanvasFont canvasFont => canvasFont -> Canvas ()
Generated.font
strokeStyle :: Text -> Canvas ()
strokeStyle :: Text -> Canvas ()
strokeStyle = forall style. Style style => style -> Canvas ()
Generated.strokeStyle
shadowColor :: Text -> Canvas ()
shadowColor :: Text -> Canvas ()
shadowColor = forall canvasColor.
CanvasColor canvasColor =>
canvasColor -> Canvas ()
Generated.shadowColor
addColorStop :: (Interval, Text) -> CanvasGradient -> Canvas ()
addColorStop :: (Double, Text) -> CanvasGradient -> Canvas ()
addColorStop = forall color.
CanvasColor color =>
(Double, color) -> CanvasGradient -> Canvas ()
Canvas.addColorStop
cursor :: Text -> Canvas ()
cursor :: Text -> Canvas ()
cursor = forall cursor. CanvasCursor cursor => cursor -> Canvas ()
Canvas.cursor
height :: (Image image, Num a) => image -> a
height :: forall image a. (Image image, Num a) => image -> a
height = forall a b. (Image a, Num b) => a -> b
JavaScript.height
width :: (Image image, Num a) => image -> a
width :: forall image a. (Image image, Num a) => image -> a
width = forall a b. (Image a, Num b) => a -> b
JavaScript.width