{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-|
Module:      Graphics.Blank
Copyright:   (C) 2014-2015, The University of Kansas
License:     BSD-style (see the file LICENSE)
Maintainer:  Andy Gill
Stability:   Beta
Portability: GHC

@blank-canvas@ is a Haskell binding to the complete
<https://developer.mozilla.org/en-US/docs/Web/API/Canvas_API 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 <https://developer.mozilla.org/en-US/docs/Web/API/Canvas_API> for the JavaScript
          --   version of this API.
        , Canvas        -- abstract
          -- ** 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(..)
        , butt
        , square
        , LineJoinCorner(..)
        , bevel
        , miter
          -- ** Colors, styles and shadows
        , strokeStyle
        , fillStyle
        , shadowOffsetX
        , shadowOffsetY
        , shadowBlur
        , shadowColor
        , createLinearGradient
        , createRadialGradient
        , createPattern
        , addColorStop
        , RepeatDirection(..)
        , repeat_
        , repeatX
        , repeatY
        , noRepeat
        , CanvasGradient
        , CanvasPattern
          -- ** Paths
        , beginPath
        , closePath
        , fill
        , stroke
        , clip
        , moveTo
        , lineTo
        , quadraticCurveTo
        , bezierCurveTo
        , arcTo
        , arc
        , rect
        , isPointInPath
          -- ** Text
        , font
        , textAlign
        , textBaseline
        , fillText
        , strokeText
        , measureText
        , TextAnchorAlignment(..)
        , start
        , end
        , center
        , left
        , right
        , TextBaselineAlignment(..)
        , top
        , hanging
        , middle
        , alphabetic
        , ideographic
        , bottom
        , TextMetrics(..)
          -- ** Rectangles
        , clearRect
        , fillRect
        , strokeRect
          -- ** Pixel manipulation
        , getImageData
        , putImageData
        , ImageData(..)
          -- * Type information
        , Alpha
        , Degrees
        , Interval
        , Percentage
        , Radians
        , RoundProperty(..)
        -- * @blank-canvas@ Extensions
        -- ** Reading from 'Canvas'
        , newImage
        , CanvasImage -- abstract
        , newAudio
        , CanvasAudio
         -- ** '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
        -- ** Cursor manipulation
        , cursor
        -- ** Middleware
        , 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           Network.Wai.Middleware.RequestLogger -- Used when debugging
-- import           Network.Wai.Middleware.Static

import           Paths_blank_canvas

import           Prelude.Compat

import           System.IO.Unsafe (unsafePerformIO)
-- import           System.Mem.StableName

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' 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 :: 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

--   print dataDir

   -- use the comet
   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
       -- register the events we want to watch for
       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

       -- A bit of bootstrapping
       DeviceAttributes Int
w Int
h Double
dpr <- forall a. DeviceContext -> Canvas a -> IO a
send DeviceContext
cxt0 Canvas DeviceAttributes
device
       -- print (DeviceAttributes w h dpr)

       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
--        middleware logStdoutDev
        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

        -- There has to be a better way of doing this, using function, perhaps?
        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

-- | 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 :: 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 ()

          -- send the com
          Int
uq <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ STM Int
getUniq
          -- The query function returns a function takes the unique port number of the reply.
          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
      -- Most of these can be factored out, except return
      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  -- This is a bit of a hack
      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

-------------------------------------------------

-- | Additional @blank-canvas@ settings. The defaults can be used by creating
-- 'Options' as a 'Num'. For example, @'blankCanvas' 3000@ uses the default 'Options'
-- on port 3000.
data Options = Options
        { Options -> Int
port   :: Int              -- ^ On which port do we issue @blank-canvas@?
        , Options -> [Text]
events :: [EventName]      -- ^ To which events does the canvas listen? Default: @[]@
        , Options -> Bool
debug  :: Bool             -- ^ Turn on debugging. Default: @False@
        , Options -> [Char]
root   :: String           -- ^ Location of the static files. Default: @\".\"@
        , Options -> [Middleware]
middleware :: [Middleware] -- ^ Extra middleware(s) to be executed. Default: @['local_only']@
        , Options -> Bool
weak       :: Bool         -- ^ use a weak monad, which may help debugging (default False)
        }

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
                            }

-------------------------------------------------
-- These are monomorphic versions of functions defined to curb type ambiguity errors.

-- | Sets the color used to fill a drawing (@\"black\"@ by default).
--
-- ==== __Examples__
--
-- @
-- 'fillStyle' \"red\"
-- 'fillStyle' \"#00FF00\"
-- @
fillStyle :: Text -> Canvas ()
fillStyle :: Text -> Canvas ()
fillStyle = forall style. Style style => style -> Canvas ()
Generated.fillStyle

-- | Sets the text context's font properties.
--
-- ==== __Examples__
--
-- @
-- 'font' \"40pt \'Gill Sans Extrabold\'\"
-- 'font' \"80% sans-serif\"
-- 'font' \"bold italic large serif\"
-- @
font :: Text -> Canvas ()
font :: Text -> Canvas ()
font = forall canvasFont. CanvasFont canvasFont => canvasFont -> Canvas ()
Generated.font

-- | Sets the color used for strokes (@\"black\"@ by default).
--
-- ==== __Examples__
--
-- @
-- 'strokeStyle' \"red\"
-- 'strokeStyle' \"#00FF00\"
-- @
strokeStyle :: Text -> Canvas ()
strokeStyle :: Text -> Canvas ()
strokeStyle = forall style. Style style => style -> Canvas ()
Generated.strokeStyle

-- | Sets the color used for shadows.
--
-- ==== __Examples__
--
-- @
-- 'shadowColor' \"red\"
-- 'shadowColor' \"#00FF00\"
-- @
shadowColor :: Text -> Canvas ()
shadowColor :: Text -> Canvas ()
shadowColor = forall canvasColor.
CanvasColor canvasColor =>
canvasColor -> Canvas ()
Generated.shadowColor

-- | Adds a color and stop position in a 'CanvasGradient'. A stop position is a
-- number between 0.0 and 1.0 that represents the position between start and stop
-- in a gradient.
--
-- ==== __Example__
--
-- @
-- grd <- 'createLinearGradient'(0, 0, 10, 10)
-- grd # 'addColorStop'(0, \"red\")
-- @
addColorStop :: (Interval, Text) -> CanvasGradient -> Canvas ()
addColorStop :: (Double, Text) -> CanvasGradient -> Canvas ()
addColorStop = forall color.
CanvasColor color =>
(Double, color) -> CanvasGradient -> Canvas ()
Canvas.addColorStop

-- | Change the canvas cursor to the specified URL or keyword.
--
-- ==== __Examples__
--
-- @
-- cursor \"url(image.png), default\"
-- cursor \"crosshair\"
-- @
cursor :: Text -> Canvas ()
cursor :: Text -> Canvas ()
cursor = forall cursor. CanvasCursor cursor => cursor -> Canvas ()
Canvas.cursor

-- | The height of an 'Image' in pixels.
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

-- | The width of an 'Image' in pixels.
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