diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright 2012-2013, Anton Ekblad +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the Anton Ekblad nor the names of his contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/haste-lib.cabal b/haste-lib.cabal new file mode 100644 --- /dev/null +++ b/haste-lib.cabal @@ -0,0 +1,82 @@ +Name: haste-lib +Version: 0.6.0.0 +License: BSD3 +License-File: LICENSE +Category: Web +Synopsis: Base libraries for haste-compiler. +Description: Base libraries for haste-compiler. Only useful for web development, with Haste or vanilla GHC + haste-app. +Cabal-Version: >= 1.10 +Build-Type: Simple +Author: Anton Ekblad +Maintainer: anton@ekblad.cc +Homepage: http://github.com/valderman/haste-compiler +Bug-reports: http://github.com/valderman/haste-compiler/issues +Stability: Experimental + +flag haste + description: Is haste-lib being installed for Haste? + default: False + +Library + Hs-Source-Dirs: src + GHC-Options: -Wall -O2 + Exposed-Modules: + Haste + Haste.Ajax + Haste.Audio + Haste.Binary + Haste.Concurrent + Haste.Crypto + Haste.DOM + Haste.DOM.JSString + Haste.Events + Haste.Foreign + Haste.Graphics.AnimationFrame + Haste.Graphics.Canvas + Haste.JSON + Haste.JSString + Haste.LocalStorage + Haste.Parsing + Haste.Performance + Haste.Serialize + Haste.WebSockets + Other-Modules: + Haste.Audio.Events + Haste.Binary.Get + Haste.Binary.Put + Haste.Binary.Types + Haste.Concurrent.Monad + Haste.Crypto.Prim + Haste.Crypto.Types + Haste.DOM.Core + Haste.Events.BasicEvents + Haste.Events.Core + Haste.Events.KeyEvents + Haste.Events.MessageEvents + Haste.Events.MouseEvents + Haste.Events.TouchEvents + Haste.Foreign.Array + Haste.Hash + Haste.Timer + Build-Depends: + base >= 4.8 && < 5, + integer-gmp, + transformers, + monads-tf, + ghc-prim, + containers > 0.5.6 && < 0.5.7, + bytestring < 0.11, + haste-prim == 0.6.0.0, + time == 1.5.0.1 + if flag(haste) + Build-Depends: + array == 0.5.1.0, + hashable >= 1.2 && < 1.3 + else + Build-Depends: + array, + random, + binary >= 0.7 && < 0.8, + data-binary-ieee754 >= 0.4 && < 0.5, + utf8-string >= 1 && < 2 + Default-Language: Haskell98 diff --git a/src/Haste.hs b/src/Haste.hs new file mode 100644 --- /dev/null +++ b/src/Haste.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, OverloadedStrings #-} +-- | Haste's companion to the Prelude. +module Haste ( + -- * Basic utility functions + JSString, JSAny, URL, MonadIO (..), + alert, prompt, eval, writeLog, catJSStr, fromJSStr, + + -- * Location handling + onHashChange, setHash, getHash, + getLocationHref, setLocationHref, getLocationHostName, getLocationPort, + + -- * Timers + Timer, Interval (..), setTimer, stopTimer, + + -- * Fast conversions for JS-native types + JSType (..), JSNum (..), toString, fromString, convert, + + -- * Reflection + getProgramId, getProgramJS + ) where +import Haste.Prim +import Haste.Timer +import Haste.Prim.JSType +import Haste.Hash +import Haste.Foreign +import Control.Monad.IO.Class + +jsAlert :: JSString -> IO () +jsAlert = ffi "alert" + +jsLog :: JSString -> IO () +jsLog = ffi "(function(x){console.log(x);})" + +jsPrompt :: JSString -> IO JSString +jsPrompt = ffi "(function(s){var x = prompt(s);\ +\return (x === null) ? '' : x.toString();})" + +jsEval :: JSString -> IO JSString +jsEval = ffi "(function(s){var x = eval(s);\ +\return (typeof x === 'undefined') ? 'undefined' : x.toString();})" + +-- | JavaScript @alert()@ function. +alert :: MonadIO m => JSString -> m () +alert = liftIO . jsAlert + +-- | JavaScript @prompt()@ function. +prompt :: MonadIO m => JSString -> m JSString +prompt = liftIO . jsPrompt + +-- | JavaScript @eval()@ function. +eval :: MonadIO m => JSString -> m JSString +eval = liftIO . jsEval + +-- | JavaScript @console.log()@. +writeLog :: MonadIO m => JSString -> m () +writeLog = liftIO . jsLog + +-- | Get the value of the @__haste_prog_id@ variable. Unless programmatically +-- changed, this variable contains the SHA3-256 hash of the currently +-- executing Haste program. +getProgramId :: MonadIO m => m JSString +getProgramId = liftIO getProgramId' + +getProgramId' :: IO JSString +getProgramId' = ffi "(function(){return __haste_prog_id;})" + +-- | Get the complete JavaScript source code of the currently executing Haste +-- program. On IE, this requires that the program's identifier, as returned +-- by 'getProgramId', has not been tampered with. +getProgramJS :: MonadIO m => m (Either URL JSString) +getProgramJS = liftIO $ do + (murl, msrc) <- getCurrentScript + return $ maybe (maybe impossible Right msrc) Left murl + where + impossible = error "impossible!" + +-- | JS worker for 'getProgramJS'. +getCurrentScript :: IO (Maybe URL, Maybe JSString) +getCurrentScript = ffi "(function(){\ +\ if(__haste_script_elem) {\ +\ if(__haste_script_elem.innerHTML) {\ +\ return [null, __haste_script_elem.innerHTML];\ +\ } else {\ +\ return [__haste_script_elem.src, null];\ +\ }\ +\ } else {\ +\ var es = document.getElementsByTagName('SCRIPT');\ +\ var re = new RegExp('var __haste_prog_id = \\'\\([0-9a-f]{64}\\)\\';');\ +\ for(var i in es) {\ +\ if(es[i].innerHTML) {\ +\ var match = es[i].innerHTML.match(re);\ +\ if(match && match[1] == __haste_prog_id) {\ +\ return [null, es[i].innerHTML];\ +\ }\ +\ } else if(es[i].src) {\ +\ var xhr = new XMLHttpRequest();\ +\ xhr.open('GET', es[i].src, false);\ +\ xhr.send();\ +\ var match = xhr.responseText.match(re);\ +\ if(match && match[1] == __haste_prog_id) {\ +\ return [es[i].src, null];\ +\ }\ +\ }\ +\ }\ +\ }\ +\ throw 'source of current program not found';\ +\})" + +-- | Get the current complete location URL. +getLocationHref :: MonadIO m => m URL +getLocationHref = liftIO getLocationHref' + +getLocationHref' :: IO URL +getLocationHref' = ffi "(function(){return location.href;})" + +-- | Set the location URL. +setLocationHref :: MonadIO m => URL -> m () +setLocationHref href = liftIO (setLocationHref' href) + +setLocationHref' :: URL -> IO () +setLocationHref' = ffi "(function(href){location.href = href;})" + +-- | Get the current location host name. +getLocationHostName :: MonadIO m => m JSString +getLocationHostName = liftIO getLocationHostName' + +getLocationHostName' :: IO JSString +getLocationHostName' = ffi "(function(){return location.hostname;})" + +-- | Get the current location port. +getLocationPort :: MonadIO m => m Int +getLocationPort = liftIO getLocationPort' + +getLocationPort' :: IO Int +getLocationPort' = ffi "(function(){return location.port;})" diff --git a/src/Haste/Ajax.hs b/src/Haste/Ajax.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Ajax.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE GADTs, OverloadedStrings, ScopedTypeVariables #-} +-- | XMLHttpRequest support. IE9 and older are not supported. +module Haste.Ajax + ( Method (..) + , AjaxData (..) + , AjaxError (..) + , ajax, ajaxWithMime + ) where +import Haste.Prim.Foreign +import Haste.Prim +import Haste.Prim.JSType +import Control.Monad.IO.Class +import Control.Monad (join) +import Haste.Concurrent +import Data.Proxy +import Haste.Binary hiding (get) + +class (ToAny a, FromAny a) => AjaxData a where + -- | The MIME type of the data represented by this type. + mimeType :: Proxy a -> JSString + + -- | The XHR response type that corresponds to this type. + responseType :: Proxy a -> JSString + +instance AjaxData JSString where + mimeType _ = "" + responseType _ = "" + +instance AjaxData Blob where + mimeType _ = "application/octet-stream" + responseType _ = "blob" + +instance AjaxData () where + mimeType _ = "" + responseType _ = "" + +-- | Make an AJAX request. The return value is either the body of the requested +-- document, or an error. +ajax :: forall m post resp. + (MonadConc m, AjaxData post, AjaxData resp) + => Method post -- ^ HTTP method to use for request. @post@ is always @()@ + -- for GET requests. + -> URL -- ^ URL to request. + -> m (Either AjaxError resp) +ajax = ajaxWithMime "" + +-- | Like 'ajax', but accepts a custom MIME type for POST data. +-- Use this with the appropriate MIME type and POST data if you want to send, +-- for instance, form data. +ajaxWithMime :: forall m post resp. + (MonadConc m, AjaxData post, AjaxData resp) + => JSString -- ^ MIME type of any POST data. Decided by the 'AjaxData' + -- instance for @post@ if the empty string is given. + -- Only relevant to POST requests. + -> Method post -- ^ HTTP method to use for request. + -> URL -- ^ URL to request. + -> m (Either AjaxError resp) +ajaxWithMime mime method url = do + res <- newEmptyMVar + liftIO $ ajaxReq methodStr url mime' respType postdata $ \merr md -> do + case (md, merr) of + (Just d, _) -> fromAny d >>= concurrent . putMVar res . Right + (_, Just err) -> concurrent $ putMVar res (Left err) + liftCIO $ takeMVar res + where + mime' + | "" /= mime = mime + | otherwise = mimeType (Proxy :: Proxy post) + respType = responseType (Proxy :: Proxy resp) + (postdata, methodStr) = case method of + GET -> (Nothing, "GET") + POST d -> (Just $ toAny d, "POST") + PUT d -> (Just $ toAny d, "PUT") + DELETE -> (Nothing, "DELETE") + +-- | An error which occurred during an AJAX request. +-- Might be either a network error (denied by CSP, host unreachable etc.) +-- or an HTTP error, with status code and description. +data AjaxError + = NetworkError + | HttpError Int JSString + deriving (Show, Eq) + +instance FromAny AjaxError where + fromAny x = do + errtype <- get x "type" + case errtype of + "network" -> pure NetworkError + "http" -> HttpError <$> get x "status" <*> get x "status-text" + _ -> fail $ "unknown type of ajax error: " ++ fromJSStr errtype + +-- | HTTP method to use for request. POST requests take an (optionally empty) +-- JSString representing data to POST. +data Method a where + GET :: Method () + DELETE :: Method () + POST :: a -> Method a + PUT :: a -> Method a + +ajaxReq :: JSString -- ^ method (GET/POST) + -> JSString -- ^ URI + -> JSString -- ^ Outgoing MIME type; empty string means default + -> JSString -- ^ responseType field + -> Maybe JSAny -- ^ POST data + -> (Maybe AjaxError -> Maybe JSAny -> IO ()) + -- ^ Callback; if successful, first argument is 0, the second the + -- empty string, and the third the response data. + -- If not, third argument is null and the other two give + -- HTTP status and error message. + -> IO () +ajaxReq = ffi "(function(method, uri, mimeout, responseType, postdata, cb) {\ + \var xhr = new XMLHttpRequest();\ + \xhr.open(method, uri);\ + \xhr.responseType = responseType;\ + \if(mimeout != '') {\ + \xhr.setRequestHeader('Content-type', mimeout);\ + \}\ + \xhr.addEventListener('load', function() {\ + \if(xhr.status < 400) {cb(null, xhr.response);}\ + \else {cb({'type':'http', 'status':xhr.status, 'status-text': xhr.statusText}, null);}\ + \});\ + \xhr.addEventListener('error', function() {\ + \if(xhr.status != 0) {\ + \cb({'type':'http', 'status':xhr.status, 'status-text': xhr.statusText}, null);\ + \} else {\ + \cb({'type':'network'}, null);\ + \}\ + \});\ + \xhr.send(postdata);\ + \})" diff --git a/src/Haste/Audio.hs b/src/Haste/Audio.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Audio.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE OverloadedStrings, CPP #-} +-- | High-ish level bindings to the HTML5 audio tag and JS API. +module Haste.Audio ( + module Events, + Audio, AudioSettings (..), AudioType (..), AudioSource (..), + AudioPreload (..), AudioState (..), Seek (..), + defaultAudioSettings, + mkSource, newAudio, setSource, + getState, + setMute, isMute, toggleMute, + setLooping, isLooping, toggleLooping, + getVolume, setVolume, modVolume, + play, pause, stop, togglePlaying, + seek, getDuration, getCurrentTime + ) where +import Haste.Audio.Events as Events +import Haste.DOM.JSString +import Haste.Events.Core +import Haste.Prim.Foreign +import Haste.Prim.JSType +import Haste.Prim +import Control.Monad +import Control.Monad.IO.Class +import Data.String + +-- | Represents an audio player. +data Audio = Audio Elem + +instance IsElem Audio where + elemOf (Audio e) = e + fromElem e = do + tn <- getProp e "tagName" + return $ case tn of + "AUDIO" -> Just $ Audio e + _ -> Nothing + +instance EventSource Audio where + eventSource = eventSource . elemOf + +data AudioState = Playing | Paused | Ended + deriving (Show, Eq) +data AudioType = MP3 | OGG | WAV + deriving (Show, Eq) +data AudioSource = AudioSource !AudioType !JSString + deriving (Show, Eq) +data AudioPreload = None | Metadata | Auto + deriving Eq +data Seek = Start | End | Seconds Double + deriving Eq + +instance JSType AudioPreload where + toJSString None = "none" + toJSString Metadata = "metadata" + toJSString Auto = "auto" + fromJSString "none" = Just None + fromJSString "metadata" = Just Metadata + fromJSString "auto" = Just Auto + fromJSString _ = Nothing + +data AudioSettings = AudioSettings { + -- | Show controls? + -- Default: False + audioControls :: !Bool, + -- | Immediately start playing? + -- Default: False + audioAutoplay :: !Bool, + -- | Initially looping? + -- Default: False + audioLooping :: !Bool, + -- | How much audio to preload. + -- Default: Auto + audioPreload :: !AudioPreload, + -- | Initially muted? + -- Default: False + audioMuted :: !Bool, + -- | Initial volume + -- Default: 0 + audioVolume :: !Double + } + +defaultAudioSettings :: AudioSettings +defaultAudioSettings = AudioSettings { + audioControls = False, + audioAutoplay = False, + audioLooping = False, + audioPreload = Auto, + audioMuted = False, + audioVolume = 0 + } + +-- | Create an audio source with automatically detected media type, based on +-- the given URL's file extension. +-- Returns Nothing if the given URL has an unrecognized media type. +mkSource :: JSString -> Maybe AudioSource +mkSource url = + case take 3 $ reverse $ fromJSStr url of + "3pm" -> Just $ AudioSource MP3 url + "ggo" -> Just $ AudioSource OGG url + "vaw" -> Just $ AudioSource WAV url + _ -> Nothing + +instance IsString AudioSource where + fromString s = + case mkSource $ Data.String.fromString s of + Just src -> src + _ -> error $ "Not a valid audio source: " ++ s + +mimeStr :: AudioType -> JSString +mimeStr MP3 = "audio/mpeg" +mimeStr OGG = "audio/ogg" +mimeStr WAV = "audio/wav" + +-- | Create a new audio element. +newAudio :: MonadIO m => AudioSettings -> [AudioSource] -> m Audio +newAudio cfg sources = liftIO $ do + srcs <- forM sources $ \(AudioSource t url) -> do + newElem "source" `with` ["type" =: mimeStr t, "src" =: toJSString url] + Audio <$> newElem "audio" `with` [ + "controls" =: falseAsEmpty (audioControls cfg), + "autoplay" =: falseAsEmpty (audioAutoplay cfg), + "loop" =: falseAsEmpty (audioLooping cfg), + "muted" =: falseAsEmpty (audioMuted cfg), + "volume" =: toJSString (audioVolume cfg), + "preload" =: toJSString (audioPreload cfg), + children srcs + ] + +-- | Returns "true" or "", depending on the given boolean. +falseAsEmpty :: Bool -> JSString +falseAsEmpty True = "true" +falseAsEmpty _ = "" + +-- | (Un)mute the given audio object. +setMute :: MonadIO m => Audio -> Bool -> m () +setMute (Audio e) = setAttr e "muted" . falseAsEmpty + +-- | Is the given audio object muted? +isMute :: MonadIO m => Audio -> m Bool +isMute (Audio e) = liftIO $ maybe False id . fromJSString <$> getProp e "muted" + +-- | Mute/unmute. +toggleMute :: MonadIO m => Audio -> m () +toggleMute a = isMute a >>= setMute a . not + +-- | Set whether the given sound should loop upon completion or not. +setLooping :: MonadIO m => Audio -> Bool -> m () +setLooping (Audio e) = setAttr e "loop" . falseAsEmpty + +-- | Is the given audio object looping? +isLooping :: MonadIO m => Audio -> m Bool +isLooping (Audio e) = + liftIO $ maybe False id . fromJSString <$> getProp e "looping" + +-- | Toggle looping on/off. +toggleLooping :: MonadIO m => Audio -> m () +toggleLooping a = isLooping a >>= setLooping a . not + +-- | Starts playing audio from the given element. +play :: MonadIO m => Audio -> m () +play a@(Audio e) = do + st <- getState a + when (st == Ended) $ seek a Start + liftIO $ play' e + where + play' :: Elem -> IO () + play' = ffi "(function(x){x.play();})" + +-- | Get the current state of the given audio object. +getState :: MonadIO m => Audio -> m AudioState +getState (Audio e) = liftIO $ do + ended <- maybe False id . fromJSString <$> getProp e "ended" + if ended + then return Ended + else maybe Playing paused . fromJSString <$> getProp e "paused" + where + paused True = Paused + paused _ = Playing + +-- | Pause the given audio element. +pause :: MonadIO m => Audio -> m () +pause (Audio e) = liftIO $ pause' e + +pause' :: Elem -> IO () +pause' = ffi "(function(x){x.pause();})" + +-- | If playing, stop. Otherwise, start playing. +togglePlaying :: MonadIO m => Audio -> m () +togglePlaying a = do + st <- getState a + case st of + Playing -> pause a + Ended -> seek a Start >> play a + Paused -> play a + +-- | Stop playing a track, and seek back to its beginning. +stop :: MonadIO m => Audio -> m () +stop a = pause a >> seek a Start + +-- | Get the volume for the given audio element as a value between 0 and 1. +getVolume :: MonadIO m => Audio -> m Double +getVolume (Audio e) = liftIO $ maybe 0 id . fromJSString <$> getProp e "volume" + +-- | Set the volume for the given audio element. The value will be clamped to +-- [0, 1]. +setVolume :: MonadIO m => Audio -> Double -> m () +setVolume (Audio e) = setProp e "volume" . toJSString . clamp + +-- | Modify the volume for the given audio element. The resulting volume will +-- be clamped to [0, 1]. +modVolume :: MonadIO m => Audio -> Double -> m () +modVolume a diff = getVolume a >>= setVolume a . (+ diff) + +-- | Clamp a value to [0, 1]. +clamp :: Double -> Double +clamp = max 0 . min 1 + +-- | Seek to the specified time. +seek :: MonadIO m => Audio -> Seek -> m () +seek a@(Audio e) st = liftIO $ do + case st of + Start -> seek' e 0 + End -> getDuration a >>= seek' e + Seconds s -> seek' e s + where + seek' :: Elem -> Double -> IO () + seek' = ffi "(function(e,t) {e.currentTime = t;})" + +-- | Get the duration of the loaded sound, in seconds. +getDuration :: MonadIO m => Audio -> m Double +getDuration (Audio e) = do + dur <- getProp e "duration" + case fromJSString dur of + Just d -> return d + _ -> return 0 + +-- | Get the current play time of the loaded sound, in seconds. +getCurrentTime :: MonadIO m => Audio -> m Double +getCurrentTime (Audio e) = do + dur <- getProp e "currentTime" + case fromJSString dur of + Just d -> return d + _ -> return 0 + +-- | Set the source of the given audio element. +setSource :: MonadIO m => Audio -> AudioSource -> m () +setSource (Audio e) (AudioSource _ url) = setProp e "src" (toJSString url) diff --git a/src/Haste/Audio/Events.hs b/src/Haste/Audio/Events.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Audio/Events.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE TypeFamilies, OverloadedStrings #-} +-- | Audio related events. +module Haste.Audio.Events where +import Haste.Events.Core + +data AudioEvent + = AudioEnded -- ^ Audio playback ended. + | AudioError -- ^ There was some kind of error. + | AudioPaused -- ^ Audio paused. + | AudioResumed -- ^ Resumed playing after pause. + | AudioPlaying -- ^ Audio started playing, initially or after pause. + | AudioSeekBegins -- ^ Seek operation starts. + | AudioSeekEnds -- ^ Seek operation completes. + | AudioTimeUpdate -- ^ Audio object't current time changed. + | AudioProgress -- ^ Progress was made downloading audio. + | AudioStalled -- ^ Audio download stalled. + | AudioLoadStart -- ^ Start downloading audio. + | AudioLoadSuspend -- ^ Finished or paused downloading audio. + +instance Event AudioEvent where + type EventData AudioEvent = () + eventName AudioEnded = "ended" + eventName AudioError = "error" + eventName AudioPaused = "pause" + eventName AudioResumed = "play" + eventName AudioPlaying = "playing" + eventName AudioSeekBegins = "seeking" + eventName AudioSeekEnds = "seeked" + eventName AudioTimeUpdate = "timeupdate" + eventName AudioProgress = "progress" + eventName AudioStalled = "stalled" + eventName AudioLoadStart = "loadstart" + eventName AudioLoadSuspend = "suspend" + eventData _ _ = return () diff --git a/src/Haste/Binary.hs b/src/Haste/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Binary.hs @@ -0,0 +1,383 @@ +{-# LANGUAGE MagicHash, CPP, MultiParamTypeClasses, OverloadedStrings, + TypeSynonymInstances , FlexibleInstances, + GeneralizedNewtypeDeriving, BangPatterns, TypeOperators, + KindSignatures, DefaultSignatures, FlexibleInstances, + TypeSynonymInstances, FlexibleContexts, ScopedTypeVariables, + TupleSections #-} +-- | Handling of Javascript-native binary blobs. +-- +-- Generics borrowed from the binary package by Lennart Kolmodin (released under BSD3) +module Haste.Binary + ( -- * High level binary API + MonadConc, Binary (..), Blob, BlobData, encode, decode, decodeBlob + , module Haste.Binary.Put + , module Haste.Binary.Get + , Word8, Word16, Word32, Word64 + , Int8, Int16, Int32, Int64 + + -- * Working with raw blobs + , Ix, ArrView + , getBlobData, getBlobText', getBlobText + , blobSize, blobDataSize, toByteString, fromByteString, toBlob, strToBlob + , toUArray, fromUArray + ) where +import Data.Array.Unboxed +import Data.Bits +import Data.Char +import Data.Int +import Data.Word +import GHC.Fingerprint.Type +import GHC.Generics +import qualified Haste.JSString as J (length) +import Haste.Prim +import Haste.Concurrent +import Haste.Prim.Foreign hiding (get) +import Haste.Binary.Types +import Haste.Binary.Put +import Haste.Binary.Get +#ifndef __HASTE__ +import qualified Data.ByteString.Lazy.Char8 as BS (unpack) +#endif + +-- | Retrieve the raw data from a blob. +getBlobData :: MonadConc m => Blob -> m BlobData +-- | Interpret a blob as UTF-8 text, as a JSString. +getBlobText' :: MonadConc m => Blob -> m JSString + +#ifdef __HASTE__ +getBlobData b = liftCIO $ do + res <- newEmptyMVar + liftIO $ convertBlob b (mkBlobData res (blobSize b)) + takeMVar res + where + mkBlobData res len x = concurrent $ do + putMVar res (BlobData 0 len x) + + convertBlob :: Blob -> (JSAny -> IO ()) -> IO () + convertBlob = ffi "(function(b,cb){var r=new FileReader();r.onload=function(){cb(new DataView(r.result));};r.readAsArrayBuffer(b);})" + +getBlobText' b = liftCIO $ do + res <- newEmptyMVar + liftIO $ convertBlob b (concurrent . putMVar res) + takeMVar res + where + convertBlob :: Blob -> (JSString -> IO ()) -> IO () + convertBlob = ffi "(function(b,cb){var r=new FileReader();r.onload=function(){cb(r.result);};r.readAsText(b);})" +#else +getBlobData (Blob b) = return (BlobData b) +getBlobText' (Blob b) = return . toJSStr $ BS.unpack b +#endif + + +-- | Interpret a blob as UTF-8 text. +getBlobText :: MonadConc m => Blob -> m String +getBlobText b = getBlobText' b >>= return . fromJSStr + +-- | Somewhat efficient serialization/deserialization to/from binary Blobs. +-- The layout of the binaries produced/read by get/put and encode/decode may +-- change between versions. If you need a stable binary format, you should +-- make your own using the primitives in Haste.Binary.Get/Put. +class Binary a where + get :: Get a + put :: a -> Put + + default put :: (Generic a, GBinary (Rep a)) => a -> Put + put = gput . from + + default get :: (Generic a, GBinary (Rep a)) => Get a + get = to `fmap` gget + +-- | Generic version +class GBinary f where + gput :: f t -> Put + gget :: Get (f t) + +instance Binary Bool where + put True = putWord8 1 + put _ = putWord8 0 + get = do + n <- getWord8 + case n of + 0 -> pure False + 1 -> pure True + _ -> fail $ "Not a valid Bool: " ++ show n + +instance Binary Word8 where + put = putWord8 + get = getWord8 + +instance Binary Word16 where + put = putWord16le + get = getWord16le + +instance Binary Word32 where + put = putWord32le + get = getWord32le + +instance Binary Word64 where + get = do + lo <- get :: Get Word32 + hi <- get :: Get Word32 + return $ fromIntegral lo .|. shiftL (fromIntegral hi) 32 + put x = do + put (fromIntegral x :: Word32) + put (fromIntegral (shiftR x 32) :: Word32) + +instance Binary Int8 where + put = putInt8 + get = getInt8 + +instance Binary Int16 where + put = putInt16le + get = getInt16le + +instance Binary Int32 where + put = putInt32le + get = getInt32le + +instance Binary Int64 where + get = do + lo <- get :: Get Int32 + hi <- get :: Get Int32 + return $ fromIntegral lo .|. shiftL (fromIntegral hi) 32 + put x = do + put (fromIntegral x :: Int32) + put (fromIntegral (shiftR x 32) :: Int32) + +instance Binary Int where + put = putInt32le . fromIntegral + get = fromIntegral <$> getInt32le + +instance Binary Float where + put = putFloat32le + get = getFloat32le + +instance Binary Double where + put = putFloat64le + get = getFloat64le + +instance Binary Fingerprint where + get = Fingerprint <$> get <*> get + put (Fingerprint a b) = put a >> put b + +instance (Binary a, Binary b) => Binary (a, b) where + put (a, b) = put a >> put b + get = (,) <$> get <*> get +instance (Binary a, Binary b, Binary c) => Binary (a, b, c) where + put (a, b, c) = put a >> put b >> put c + get = (,,) <$> get <*> get <*> get +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a, b, c, d) where + put (a, b, c, d) = put a >> put b >> put c >> put d + get = (,,,) <$> get <*> get <*> get <*> get +instance (Binary a, Binary b, Binary c, Binary d, Binary e) + => Binary (a, b, c, d, e) where + put (a, b, c, d, e) = put a >> put b >> put c >> put d >> put e + get = (,,,,) <$> get <*> get <*> get <*> get <*> get +instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) + => Binary (a, b, c, d, e, f) where + put (a, b, c, d, e, f) = put a >> put b >> put c >> put d >> put e >> put f + get = (,,,,,) <$> get <*> get <*> get <*> get <*> get <*> get +instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) + => Binary (a, b, c, d, e, f, g) where + put (a, b, c, d, e, f, g) = put a>>put b>>put c>>put d>>put e>>put f>>put g + get = (,,,,,,) <$> get <*> get <*> get <*> get <*> get <*> get <*> get + +instance Binary a => Binary (Maybe a) where + put (Just x) = putWord8 1 >> put x + put _ = putWord8 0 + get = do + tag <- getWord8 + case tag of + 0 -> return Nothing + 1 -> Just <$> get + _ -> fail "Wrong constructor tag when reading Maybe value!" + +instance (Binary a, Binary b) => Binary (Either a b) where + put (Left x) = putWord8 0 >> put x + put (Right x) = putWord8 1 >> put x + get = do + tag <- getWord8 + case tag of + 0 -> Left <$> get + 1 -> Right <$> get + _ -> fail "Wrong constructor tag when reading Either value!" + +instance Binary () where + put _ = return () + get = return () + +instance Binary a => Binary [a] where + put xs = do + putWord32le (fromIntegral $ length xs) + mapM_ put xs + get = getWord32le >>= getMany + +instance Binary JSString where + {-# NOINLINE put #-} + put s = do + putWord32le $ fromIntegral $ J.length s + putJSString s + {-# NOINLINE get #-} + get = get >>= getJSString + +instance Binary Blob where + {-# NOINLINE put #-} + put b = do + put (blobSize b) + putBlob b + {-# NOINLINE get #-} + get = do + sz <- get + bd <- getBytes sz + return $ toBlob bd + +instance Binary Char where + put = put . ord + get = get >>= \x -> + case chr x of + !x' -> return x' + +-- Borrowed from the @binary@ package. +instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where + put a = do + put (bounds a) + put (rangeSize $ bounds a) + mapM_ put (elems a) + get = do + bs <- get + n <- get + xs <- getMany n + return (listArray bs xs) + +-- | 'getMany n' get 'n' elements in order, without blowing the stack. +{-# INLINE getMany #-} +getMany :: Binary a => Word32 -> Get [a] +getMany n = go [] n + where + go xs 0 = return $! reverse xs + go xs i = do x <- get + -- we must seq x to avoid stack overflows due to laziness in + -- (>>=) + x `seq` go (x:xs) (i-1) + +-- | Encode any serializable data into a 'Blob'. +encode :: Binary a => a -> Blob +encode x = runPut (put x) + +-- | Decode any deserializable data from a 'BlobData'. +decode :: Binary a => BlobData -> Either JSString a +decode = runGet get + +-- | Decode a 'Blob' into some deserializable value, inconveniently locked up +-- inside the 'CIO' monad (or any other concurrent monad) due to the somewhat +-- special way JavaScript uses to deal with binary data. +decodeBlob :: (MonadConc m, Binary a) => Blob -> m (Either JSString a) +decodeBlob b = getBlobData b >>= return . decode + +-- Type without constructors +instance GBinary V1 where + gput _ = return () + gget = return undefined + +-- Constructor without arguments +instance GBinary U1 where + gput U1 = return () + gget = return U1 + +-- Product: constructor with parameters +instance (GBinary a, GBinary b) => GBinary (a :*: b) where + gput (x :*: y) = gput x >> gput y + gget = (:*:) <$> gget <*> gget + +-- Metadata (constructor name, etc) +instance GBinary a => GBinary (M1 i c a) where + gput = gput . unM1 + gget = M1 <$> gget + +-- Constants, additional parameters, and rank-1 recursion +instance Binary a => GBinary (K1 i a) where + gput = put . unK1 + gget = K1 <$> get + +-- Borrowed from the cereal package. + +-- The following GBinary instance for sums has support for serializing +-- types with up to 2^64-1 constructors. It will use the minimal +-- number of bytes needed to encode the constructor. For example when +-- a type has 2^8 constructors or less it will use a single byte to +-- encode the constructor. If it has 2^16 constructors or less it will +-- use two bytes, and so on till 2^64-1. +-- +-- NB: changed to 2^32-1 constructors + +#define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD) +#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size) +#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size) + +instance ( GSum a, GSum b + , GBinary a, GBinary b + , SumSize a, SumSize b) => GBinary (a :+: b) where + gput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) -- | PUTSUM(Word64) + | otherwise = sizeError "encode" size + where + size = unTagged (sumSize :: Tagged (a :+: b) Word32) + {-# INLINE gput #-} + + gget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) -- | GETSUM(Word64) + | otherwise = sizeError "decode" size + where + size = unTagged (sumSize :: Tagged (a :+: b) Word32) + {-# INLINE gget #-} + +sizeError :: Show size => String -> size -> error +sizeError s size = + error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors" + +------------------------------------------------------------------------ + +checkGetSum :: (Ord word, Num word, Bits word, GSum f) + => word -> word -> Get (f a) +checkGetSum size code | code < size = getSum code size + | otherwise = fail "Unknown encoding for constructor" +{-# INLINE checkGetSum #-} + +class GSum f where + getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a) + putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put + +instance (GSum a, GSum b, GBinary a, GBinary b) => GSum (a :+: b) where + getSum !code !size | code < sizeL = L1 <$> getSum code sizeL + | otherwise = R1 <$> getSum (code - sizeL) sizeR + where + sizeL = size `shiftR` 1 + sizeR = size - sizeL + {-# INLINE getSum #-} + + putSum !code !size s = case s of + L1 x -> putSum code sizeL x + R1 x -> putSum (code + sizeL) sizeR x + where + sizeL = size `shiftR` 1 + sizeR = size - sizeL + {-# INLINE putSum #-} + +instance GBinary a => GSum (C1 c a) where + getSum _ _ = gget + {-# INLINE getSum #-} + + putSum !code _ x = put code *> gput x + {-# INLINE putSum #-} + +------------------------------------------------------------------------ + +class SumSize f where + sumSize :: Tagged f Word32 + +newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b} + +instance (SumSize a, SumSize b) => SumSize (a :+: b) where + sumSize = Tagged $ unTagged (sumSize :: Tagged a Word32) + + unTagged (sumSize :: Tagged b Word32) + +instance SumSize (C1 c a) where + sumSize = Tagged 1 diff --git a/src/Haste/Binary/Get.hs b/src/Haste/Binary/Get.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Binary/Get.hs @@ -0,0 +1,179 @@ +{-# Language CPP, OverloadedStrings, GeneralizedNewtypeDeriving #-} +module Haste.Binary.Get ( + Get, + getWord8, getWord16le, getWord32le, + getInt8, getInt16le, getInt32le, + getFloat32le, getFloat64le, + getBytes, getJSString, skip, + runGet + ) where +import Data.Int +import Data.Word +import Haste.Prim +import Haste.Binary.Types +import Control.Monad +import System.IO.Unsafe +import qualified Control.Exception as Ex +#ifdef __HASTE__ +import Haste.Prim.Foreign hiding (get) +#else +import Data.Char (chr) +import qualified Data.Binary as B +import qualified Data.Binary.IEEE754 as BI +import qualified Data.Binary.Get as BG +#endif + +#ifdef __HASTE__ +data Result a = Ok !Int !a | Fail !JSString +data Get a = Get {unG :: JSAny -> Int -> Result a} + +instance Functor Get where + fmap f (Get m) = Get $ \buf next -> + case m buf next of + Ok next' x -> Ok next' (f x) + Fail s -> Fail s + +instance Applicative Get where + (<*>) = ap + pure = return + +instance Monad Get where + return x = Get $ \_ next -> Ok next x + (Get m) >>= f = Get $ \buf next -> + case m buf next of + Ok next' x -> unG (f x) buf next' + Fail e -> Fail e + fail s = Get $ \_ _ -> Fail (toJSStr s) + +getW8 :: JSAny -> Int -> IO Word8 +getW8 = ffi "(function(b,i){return b.getUint8(i);})" + +getWord8 :: Get Word8 +getWord8 = + Get $ \buf next -> Ok (next+1) (unsafePerformIO $ getW8 buf next) + +getW16le :: JSAny -> Int -> IO Word16 +getW16le = ffi "(function(b,i){return b.getUint16(i,true);})" + +getWord16le :: Get Word16 +getWord16le = + Get $ \buf next -> Ok (next+2) (unsafePerformIO $ getW16le buf next) + +getW32le :: JSAny -> Int -> IO Word32 +getW32le = ffi "(function(b,i){return b.getUint32(i,true);})" + +getWord32le :: Get Word32 +getWord32le = + Get $ \buf next -> Ok (next+4) (unsafePerformIO $ getW32le buf next) + +getI8 :: JSAny -> Int -> IO Int8 +getI8 = ffi "(function(b,i){return b.getInt8(i);})" + +getInt8 :: Get Int8 +getInt8 = + Get $ \buf next -> Ok (next+1) (unsafePerformIO $ getI8 buf next) + +getI16le :: JSAny -> Int -> IO Int16 +getI16le = ffi "(function(b,i){return b.getInt16(i,true);})" + +getInt16le :: Get Int16 +getInt16le = + Get $ \buf next -> Ok (next+2) (unsafePerformIO $ getI16le buf next) + +getI32le :: JSAny -> Int -> IO Int32 +getI32le = ffi "(function(b,i){return b.getInt32(i,true);})" + +getInt32le :: Get Int32 +getInt32le = + Get $ \buf next -> Ok (next+4) (unsafePerformIO $ getI32le buf next) + +getF32le :: JSAny -> Int -> IO Float +getF32le = ffi "(function(b,i){return b.getFloat32(i,true);})" + +getFloat32le :: Get Float +getFloat32le = + Get $ \buf next -> Ok (next+4) (unsafePerformIO $ getF32le buf next) + +getF64le :: JSAny -> Int -> IO Double +getF64le = ffi "(function(b,i){return b.getFloat64(i,true);})" + +getFloat64le :: Get Double +getFloat64le = + Get $ \buf next -> Ok (next+8) (unsafePerformIO $ getF64le buf next) + +getBytes :: Int -> Get BlobData +getBytes len = Get $ \buf next -> Ok (next+len) (BlobData next len buf) + +-- | Read a 'JSString' of @n@ characters. Encoding is assumed to be UTF-16. +getJSString :: Word32 -> Get JSString +getJSString len = Get $ \buf next -> + Ok (next+fromIntegral (len+len)) (unsafePerformIO $ getJSS buf next len) + +getJSS :: JSAny -> Int -> Word32 -> IO JSString +getJSS = ffi "(function(b,off,len){return String.fromCharCode.apply(null,new Uint16Array(b.buffer,off,len));})" + +-- | Skip n bytes of input. +skip :: Int -> Get () +skip len = Get $ \_buf next -> Ok (next+len) () + +-- | Run a Get computation. +runGet :: Get a -> BlobData -> Either JSString a +runGet (Get p) (BlobData off len bd) = do + let res = unsafePerformIO $ do + Ex.catch (pure $! p bd off) + (\(JSException e) -> pure (Fail e)) + case res of + Ok consumed x + | consumed <= len -> Right x + | otherwise -> Left "Not enough data!" + Fail s -> Left s + +#else + +newtype Get a = Get (BG.Get a) deriving (Functor, Applicative, Monad) + +runGet :: Get a -> BlobData -> Either JSString a +runGet (Get g) (BlobData bd) = unsafePerformIO $ do + Ex.catch (Right <$> (return $! BG.runGet g bd)) mEx + +mEx :: Ex.SomeException -> IO (Either JSString a) +mEx ex = return . Left $ toJSStr $ show ex + +getWord8 :: Get Word8 +getWord8 = Get BG.getWord8 + +getWord16le :: Get Word16 +getWord16le = Get BG.getWord16le + +getWord32le :: Get Word32 +getWord32le = Get BG.getWord32le + +getInt8 :: Get Int8 +getInt8 = Get B.get + +getInt16le :: Get Int16 +getInt16le = fromIntegral <$> getWord16le + +getInt32le :: Get Int32 +getInt32le = fromIntegral <$> getWord32le + +getFloat32le :: Get Float +getFloat32le = Get BI.getFloat32le + +getFloat64le :: Get Double +getFloat64le = Get BI.getFloat64le + +getBytes :: Int -> Get BlobData +getBytes len = Get $ do + bs <- BG.getLazyByteString (fromIntegral len) + return (BlobData bs) + +getJSString :: Int -> Get JSString +getJSString len = Get $ do + toJSStr `fmap` forM [1..len] (\_ -> fmap (chr . fromIntegral) BG.getWord16le) + +-- | Skip n bytes of input. +skip :: Int -> Get () +skip = Get . BG.skip + +#endif diff --git a/src/Haste/Binary/Put.hs b/src/Haste/Binary/Put.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Binary/Put.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE CPP, OverloadedStrings, GeneralizedNewtypeDeriving #-} +module Haste.Binary.Put ( + Put, PutM, + putWord8, putWord16le, putWord32le, + putInt8, putInt16le, putInt32le, + putFloat32le, putFloat64le, + putBlob, putJSString, + runPut + ) where +import Data.Int +import Data.Word +import Haste.Prim +import Haste.Binary.Types +#ifdef __HASTE__ +import Control.Monad +import Haste.Prim.Foreign +import System.IO.Unsafe +#else +import Data.Char (ord) +import qualified Data.Binary as B +import qualified Data.Binary.IEEE754 as BI +import qualified Data.Binary.Put as BP +#endif + +type Put = PutM () + +#ifdef __HASTE__ +type JSArr = JSAny +newArr :: IO JSArr +newArr = ffi "(function(){return [];})" + +push :: JSArr -> JSAny -> IO () +push = ffi "(function(a,x) {a.push(x);})" + +data PutM a = PutM {unP :: JSArr -> IO a} + +instance Functor PutM where + fmap f (PutM m) = PutM $ \a -> fmap f (m a) + +instance Applicative PutM where + (<*>) = ap + pure = return + +instance Monad PutM where + return x = PutM $ \_ -> return x + PutM m >>= f = PutM $ \a -> do + x <- m a + unP (f x) a + +putWord8 :: Word8 -> Put +putWord8 w = PutM $ \a -> push a (toAB "Uint8Array" 1 w) + +putWord16le :: Word16 -> Put +putWord16le w = PutM $ \a -> push a (toAB "Uint16Array" 2 w) + +putWord32le :: Word32 -> Put +putWord32le w = PutM $ \a -> push a (toAB "Uint32Array" 4 w) + +putInt8 :: Int8 -> Put +putInt8 i = PutM $ \a -> push a (toAB "Int8Array" 1 i) + +putInt16le :: Int16 -> Put +putInt16le i = PutM $ \a -> push a (toAB "Int16Array" 2 i) + +putInt32le :: Int32 -> Put +putInt32le i = PutM $ \a -> push a (toAB "Int32Array" 4 i) + +putFloat32le :: Float -> Put +putFloat32le f = PutM $ \a -> push a (unsafePerformIO $ f2ab f) + +f2ab :: Float -> IO JSAny +f2ab = ffi "(function(f) {var a=new ArrayBuffer(4);new DataView(a).setFloat32(0,f,true);return a;})" + +putFloat64le :: Double -> Put +putFloat64le f = PutM $ \a -> push a (unsafePerformIO $ d2ab f) + +d2ab :: Double -> IO JSAny +d2ab = ffi "(function(f) {var a=new ArrayBuffer(8);new DataView(a).setFloat64(0,f,true);return a;})" + +-- | Write a Blob verbatim into the output stream. +putBlob :: Blob -> Put +putBlob b = PutM $ \a -> push a (toAny b) + +toAB :: ToAny a => JSString -> Int -> a -> JSAny +toAB view size el = unsafePerformIO $ toABle view size (toAny el) + +toABle :: ToAny a => JSString -> Int -> a -> IO JSAny +toABle s n x = jsToABle s n (toAny x) + +jsToABle :: JSString -> Int -> JSAny -> IO JSAny +jsToABle = ffi "window['toABle']" + +-- | Serialize a 'JSString' as UTF-16 (somewhat) efficiently. +putJSString :: JSString -> Put +putJSString s = PutM $ \a -> push a (unsafePerformIO $ str2ab s) + +str2ab :: JSString -> IO JSAny +str2ab = ffi "(function(s) {\ + var l = s.length;\ + var v = new Uint16Array(new ArrayBuffer(l*2));\ + for (var i=0; i Blob +runPut (PutM putEverything) = unsafePerformIO $ do + a <- newArr + putEverything a + jsGetBlob a + +jsGetBlob :: JSArr -> IO Blob +jsGetBlob = ffi "(function(parts){return new Blob(parts);})" + +#else + +newtype PutM a = PutM (BP.PutM a) deriving (Functor, Applicative, Monad) + +runPut :: Put -> Blob +runPut (PutM p) = Blob (BP.runPut p) + +putWord8 :: Word8 -> Put +putWord8 = PutM . BP.putWord8 + +putWord16le :: Word16 -> Put +putWord16le = PutM . BP.putWord16le + +putWord32le :: Word32 -> Put +putWord32le = PutM . BP.putWord32le + +putInt8 :: Int8 -> Put +putInt8 = PutM . B.put + +putInt16le :: Int16 -> Put +putInt16le = putWord16le . fromIntegral + +putInt32le :: Int32 -> Put +putInt32le = putWord32le . fromIntegral + +putFloat32le :: Float -> Put +putFloat32le = PutM . BI.putFloat32le + +putFloat64le :: Double -> Put +putFloat64le = PutM . BI.putFloat64le + +putBlob :: Blob -> Put +putBlob (Blob b) = PutM $ BP.putLazyByteString b + +-- | Serialize a 'JSString' as UTF-16 (somewhat) efficiently. +putJSString :: JSString -> Put +putJSString = mapM_ (putWord16le . fromIntegral . ord) . fromJSStr + +#endif diff --git a/src/Haste/Binary/Types.hs b/src/Haste/Binary/Types.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Binary/Types.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, OverloadedStrings #-} +module Haste.Binary.Types ( + Ix, ArrView, Blob (..), BlobData (..), + blobSize, blobDataSize, toByteString, fromByteString, toBlob, strToBlob, + toUArray, fromUArray + ) where +import Haste.Prim +import Haste.Prim.Foreign +import Haste.Foreign.Array +import qualified Data.ByteString.Lazy as BS +import Data.Array.Unboxed +#ifndef __HASTE__ +import qualified Data.ByteString.UTF8 as BU +#else +import System.IO.Unsafe +#endif + +#ifdef __HASTE__ +-- | In a browser context, BlobData is essentially a DataView, with an +-- accompanying offset and length for fast slicing. +-- In a server context, it is simply a 'BS.ByteString'. +data BlobData = BlobData Int Int JSAny + +-- | A JavaScript Blob on the client, a 'BS.ByteString' on the server. +newtype Blob = Blob JSAny deriving (ToAny, FromAny) + +-- | The size, in bytes, of the contents of the given blob. +blobSize :: Blob -> Int +blobSize = unsafePerformIO . ffi "(function(b){return b.size;})" + +-- | The size, in bytes, of the contents of the given blob data. +blobDataSize :: BlobData -> Int +blobDataSize (BlobData _ len _) = len + +-- | Convert a 'BlobData' to an unboxed array; client-side only. +toUArray :: (Ix i, ArrView e) => BlobData -> UArray i e +toUArray (BlobData from to buf) = unsafePerformIO $ toUArray' from to buf + +-- | Convert a an unboxed array into a 'Blob'; client-side only. +fromUArray :: (Ix i, ArrView e) => UArray i e -> Blob +fromUArray = unsafePerformIO . fromUArray' + +fromUArray' :: (Ix i, ArrView e) => UArray i e -> IO Blob +fromUArray' = ffi "(function(arr){return new Blob([arr]);})" + +toUArray' :: (Ix i, ArrView e) => Int -> Int -> JSAny -> IO (UArray i e) +toUArray' = ffi "(function(from, to, buf){return new Uint8Array(buf.buffer.slice(from, to+from));})" + +-- | Convert a BlobData to a ByteString. Only usable server-side. +toByteString :: BlobData -> BS.ByteString +toByteString = + error "Haste.Binary.Types.toByteString called in browser context!" + +-- | Convert a ByteString to a BlobData. Only usable server-side. +fromByteString :: BS.ByteString -> BlobData +fromByteString = + error "Haste.Binary.Types.toByteString called in browser context!" + +-- | Convert a piece of BlobData back into a Blob. +toBlob :: BlobData -> Blob +toBlob (BlobData 0 len buf) = + case newBlob buf of + b | blobSize b > len -> sliceBlob b 0 len + | otherwise -> b +toBlob (BlobData off len buf) = + sliceBlob (newBlob buf) off (off+len) + +-- | Create a Blob from a JSString. +strToBlob :: JSString -> Blob +strToBlob = newBlob . toAny + +sliceBlob :: Blob -> Int -> Int -> Blob +sliceBlob b off len = unsafePerformIO $ jsSlice b off len + +jsSlice :: Blob -> Int -> Int -> IO Blob +jsSlice = ffi "(function(b,off,len){return b.slice(off,len);})" + +newBlob :: JSAny -> Blob +newBlob = unsafePerformIO . jsNewBlob + +jsNewBlob :: JSAny -> IO Blob +jsNewBlob = + ffi "(function(b){try {return new Blob([b]);} catch (e) {return new Blob([b.buffer]);}})" +#else + +-- | In a browser context, BlobData is essentially a DataView, with an +-- accompanying offset and length for fast slicing. +-- In a server context, it is simply a 'BS.ByteString'. +newtype BlobData = BlobData BS.ByteString + +-- | A JavaScript Blob on the client, a 'BS.ByteString' on the server. +newtype Blob = Blob BS.ByteString + +-- Never used except for type checking +clientOnly :: a +clientOnly = error "ToAny/FromAny only usable client-side!" +instance ToAny BlobData where toAny = clientOnly +instance FromAny BlobData where fromAny = clientOnly +instance ToAny Blob where toAny = clientOnly +instance FromAny Blob where fromAny = clientOnly + +-- | Convert a 'BlobData' to an unboxed array; client-side only. +toUArray :: (Ix i, ArrView e) => BlobData -> UArray i e +toUArray _ = error "toUArray only usable client-side!" + +-- | Convert a an unboxed array into a 'Blob'; client-side only. +fromUArray :: (Ix i, ArrView e) => UArray i e -> Blob +fromUArray = error "fromUArray only usable client-side!" + +-- | The size, in bytes, of the contents of the given blob. +blobSize :: Blob -> Int +blobSize (Blob b) = fromIntegral $ BS.length b + +-- | The size, in bytes, of the contents of the given blob data. +blobDataSize :: BlobData -> Int +blobDataSize (BlobData bd) = fromIntegral $ BS.length bd + +-- | Convert a BlobData to a ByteString. Only usable server-side. +toByteString :: BlobData -> BS.ByteString +toByteString (BlobData bd) = bd + +-- | Convert a ByteString to a BlobData. Only usable server-side. +fromByteString :: BS.ByteString -> BlobData +fromByteString = BlobData + +-- | Convert a piece of BlobData back into a Blob. +toBlob :: BlobData -> Blob +toBlob (BlobData bs) = Blob bs + +-- | Create a Blob from a JSString. +strToBlob :: JSString -> Blob +strToBlob s = Blob $ BS.fromChunks [BU.fromString $ fromJSStr s] + +#endif diff --git a/src/Haste/Concurrent.hs b/src/Haste/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Concurrent.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeFamilies, + EmptyDataDecls #-} +-- | Concurrency for Haste. Includes MVars, forking, Ajax and more. +module Haste.Concurrent ( + module Haste.Concurrent.Monad, + wait, withResult + ) where +import Haste.Concurrent.Monad +import Haste.Timer + +-- | Wait for n milliseconds. +wait :: Int -> CIO () +wait ms = do + v <- newEmptyMVar + _ <- liftIO $ setTimer (Once ms) $ concurrent $ putMVar v () + takeMVar v + +-- | When the given concurrent computation is done, pass the result to the +-- given callback. +withResult :: CIO a -> (a -> IO ()) -> IO () +withResult m f = concurrent $ m >>= liftIO . f diff --git a/src/Haste/Concurrent/Monad.hs b/src/Haste/Concurrent/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Concurrent/Monad.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE GADTs, TypeFamilies, FlexibleInstances, FlexibleContexts, CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | Implements concurrency for Haste based on "A Poor Man's Concurrency Monad". +module Haste.Concurrent.Monad ( + MVar, CIO, MonadConc (..), + forkIO, forkMany, newMVar, newEmptyMVar, takeMVar, putMVar, withMVarIO, + modifyMVarIO, readMVar, concurrent, liftIO, + tryTakeMVar, tryPutMVar + ) where +import Control.Monad.IO.Class +import Control.Monad +import Data.IORef +import Haste.Events.Core (MonadEvent (..)) + +#ifndef __HASTE__ + +-- Running native: proper concurrency + +import qualified Control.Concurrent as CC + +-- | Concurrent IO monad. The normal IO monad does not have concurrency +-- capabilities with Haste. This monad is basically IO plus concurrency. +newtype CIO a = CIO (IO a) + deriving (Functor, Applicative, Monad, MonadIO) + +newtype MVar a = MVar {unV :: CC.MVar a} + +-- | Run a concurrent computation. Two different concurrent computations may +-- share MVars; if this is the case, then a call to `concurrent` may return +-- before all the threads it spawned finish executing. +concurrent :: CIO () -> IO () +concurrent (CIO m) = m + +-- | Spawn a new thread. +forkIO :: CIO () -> CIO () +forkIO (CIO m) = CIO $ void $ CC.forkIO m + +-- | Spawn several threads at once. +forkMany :: [CIO ()] -> CIO () +forkMany = mapM_ forkIO + +-- | Create a new MVar with an initial value. +newMVar :: MonadIO m => a -> m (MVar a) +newMVar = fmap MVar . liftIO . CC.newMVar + +-- | Create a new empty MVar. +newEmptyMVar :: MonadIO m => m (MVar a) +newEmptyMVar = MVar <$> liftIO CC.newEmptyMVar + +-- | Read an MVar. Blocks if the MVar is empty. +-- Only the first writer in the write queue, if any, is woken. +takeMVar :: MonadConc m => MVar a -> m a +takeMVar = liftIO . CC.takeMVar . unV + +-- | Try to take a value from an MVar, but return @Nothing@ if it is empty. +tryTakeMVar :: MonadConc m => MVar a -> m (Maybe a) +tryTakeMVar = liftIO . CC.tryTakeMVar . unV + +-- | Write an MVar. Blocks if the MVar is already full. +-- Only the first reader in the read queue, if any, is woken. +putMVar :: MonadConc m => MVar a -> a -> m () +putMVar (MVar v) x = liftIO $ CC.putMVar v x + +-- | Try to put a value into an MVar, returning @False@ if the MVar is already +-- full. +tryPutMVar :: MonadConc m => MVar a -> a -> m Bool +tryPutMVar (MVar v) x = liftIO $ CC.tryPutMVar v x +#else + +-- Running in Haste: poor man's concurrency +-- See native version for docs. + +data MV a + = Full a [(a, CIO ())] -- A full MVar: a queue of writers + | Empty [a -> CIO ()] -- An empty MVar: a queue of readers +newtype MVar a = MVar (IORef (MV a)) + +data Action where + Atom :: IO Action -> Action + Fork :: [Action] -> Action + Stop :: Action + +newtype CIO a = C {unC :: (a -> Action) -> Action} + +instance Monad CIO where + return x = C $ \next -> next x + (C m) >>= f = C $ \b -> m (\a -> unC (f a) b) + +instance Functor CIO where + fmap f m = do + x <- m + return $ f x + +instance Applicative CIO where + (<*>) = ap + pure = return + +instance MonadIO CIO where + liftIO m = C $ \next -> Atom (fmap next m) + +callCC f = C $ \next -> unC (f (\a -> C $ \_ -> next a)) next + +forkIO :: CIO () -> CIO () +forkIO (C m) = C $ \next -> Fork [next (), m (const Stop)] + +forkMany :: [CIO ()] -> CIO () +forkMany ms = C $ \next -> Fork (next () : [act (const Stop) | C act <- ms]) + +newMVar :: MonadIO m => a -> m (MVar a) +newMVar a = liftIO $ MVar `fmap` newIORef (Full a []) + +newEmptyMVar :: MonadIO m => m (MVar a) +newEmptyMVar = liftIO $ MVar `fmap` newIORef (Empty []) + +takeMVar :: MonadConc m => MVar a -> m a +takeMVar (MVar ref) = liftCIO $ do + callCC $ \next -> join $ liftIO $ do + v <- readIORef ref + case v of + Full x ((x',w):ws) -> do + writeIORef ref (Full x' ws) + return $ forkIO w >> return x + Full x _ -> do + writeIORef ref (Empty []) + return $ return x + Empty rs -> do + writeIORef ref (Empty (rs ++ [next])) + return $ C (const Stop) + +tryTakeMVar :: MonadConc m => MVar a -> m (Maybe a) +tryTakeMVar (MVar ref) = liftCIO $ do + join $ liftIO $ do + v <- readIORef ref + case v of + Full x ((x',w):ws) -> do + writeIORef ref (Full x' ws) + return $ forkIO w >> return (Just x) + Full x _ -> do + writeIORef ref (Empty []) + return $ return (Just x) + Empty rs -> do + return $ return Nothing + +putMVar :: MonadConc m => MVar a -> a -> m () +putMVar (MVar ref) x = liftCIO $ do + callCC $ \next -> join $ liftIO $ do + v <- readIORef ref + case v of + Full oldx ws -> do + writeIORef ref (Full oldx (ws ++ [(x, next ())])) + return $ C (const Stop) + Empty (r:rs) -> do + writeIORef ref (Empty rs) + return $ forkIO (r x) + Empty _ -> do + writeIORef ref (Full x []) + return $ return () + +tryPutMVar :: MonadConc m => MVar a -> a -> m Bool +tryPutMVar (MVar ref) x = liftCIO $ do + join $ liftIO $ do + v <- readIORef ref + case v of + Full oldx ws -> do + return $ return False + Empty (r:rs) -> do + writeIORef ref (Empty rs) + return $ forkIO (r x) >> return True + Empty _ -> do + writeIORef ref (Full x []) + return $ return True + +concurrent :: CIO () -> IO () +concurrent (C m) = scheduler [m (const Stop)] + where + scheduler (p:ps) = + case p of + Atom io -> do + next <- io + scheduler (ps ++ [next]) + Fork ps' -> do + scheduler (ps ++ ps') + Stop -> do + scheduler ps + scheduler _ = + return () +#endif + +-- | Any monad which supports concurrency. +class MonadIO m => MonadConc m where + liftCIO :: CIO a -> m a + fork :: m () -> m () + +instance MonadConc CIO where + liftCIO = id + fork = forkIO + +instance MonadEvent CIO where + mkHandler = return . fmap concurrent + +-- | Read an MVar then put it back. As Javascript is single threaded, this +-- function is atomic. If this ever changes, this function will only be +-- atomic as long as no other thread attempts to write to the MVar. +readMVar :: MonadConc m => MVar a -> m a +readMVar m = do + x <- takeMVar m + putMVar m x + return x + +-- | Perform an IO action over an MVar. +withMVarIO :: MonadConc m => MVar a -> (a -> IO b) -> m b +withMVarIO v m = takeMVar v >>= liftIO . m + +-- | Perform an IO action over an MVar, then write the MVar back. +modifyMVarIO :: MonadConc m => MVar a -> (a -> IO (a, b)) -> m b +modifyMVarIO v m = do + (x, res) <- withMVarIO v m + putMVar v x + return res diff --git a/src/Haste/Crypto.hs b/src/Haste/Crypto.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Crypto.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} +module Haste.Crypto + ( MonadConc (..), MonadIO (..), Binary (..), ArrView (..) + , Word8, Word16, Word32, Word64 + -- * Crypto-strength random number generation + , CryptoRandom (..) + , cryptoRandomSalt + , cryptoRandomUArray + , cryptoRandomIOUArray + + -- * SubtleCrypto API. Presently only supports symmetric encryption, due to + -- lack of browser support for other components. + , Cipher (..), CipherMode (..), KeyLength (..), SymmetricKey, IV (..) + , Salt (..), Password + , generateKey, generateIV, keyFromBytes, getKeyBytes, deriveKey, keyCipher + , encrypt, decrypt + , encryptWithIV, decryptWithIV + , encryptUArray, decryptUArray + ) where +import Control.Monad +import Control.Monad.IO.Class +import Haste +import Haste.Binary +import Haste.Concurrent +import Haste.Foreign (toAny, fromAny) +import Data.Word +import Data.Int +import Data.Array.IO +import Data.Array.Unboxed +import System.IO.Unsafe + +import Haste.Crypto.Types +import Haste.Crypto.Prim + +-- crypto.getRandomBytes bindings + +class CryptoRandom a where + -- | Generate an element of type @a@ using the browser's crypto strength + -- random bit generator. + cryptoRandom :: MonadIO m => m a + + -- | Generate @n@ random elements of type @a@. + cryptoRandoms :: MonadIO m => Word32 -> m [a] + cryptoRandoms n = mapM (const cryptoRandom) [1..n] + +instance ArrView a => CryptoRandom a where + cryptoRandom = randomPrimitive + cryptoRandoms = cryptoRandomIOUArray >=> liftIO . getElems + +-- | Generate a random immutable array of @n@ elements. +cryptoRandomUArray :: (MonadIO m, ArrView a) => Word32 -> m (UArray Word32 a) +cryptoRandomUArray = cryptoRandomIOUArray >=> liftIO . unsafeFreeze + +-- | Generate a random mutable array of @n@ elements. +cryptoRandomIOUArray :: (MonadIO m, ArrView a) => Word32 -> m (IOUArray Word32 a) +cryptoRandomIOUArray n = liftIO $ do + a <- newArray_ (0, n-1) + randomBits a + return a + +-- | Generate a random salt of the given length. +{-# INLINE cryptoRandomSalt #-} +cryptoRandomSalt :: MonadIO m => Word32 -> m Salt +cryptoRandomSalt = fmap Salt . cryptoRandomUArray + +-- | Generate a random primitive using @window.crypto@. +randomPrimitive :: (MonadIO m, ArrView a) => m a +randomPrimitive = cryptoRandomIOUArray 1 >>= liftIO . flip readArray 0 + +-- | Freeze a mutable array into an immutable one. Only safe if the source +-- array is guaranteed to never be mutated post-freeze. +unsafeFreeze :: (Ix i, ArrView e) => IOUArray i e -> IO (UArray i e) +unsafeFreeze = pure . toAny >=> fromAny + + + +-- Partial SubtleCrypto bindings + +-- | Generate a key for the given cipher. +generateKey :: MonadConc m => Cipher -> m SymmetricKey +generateKey = promise . generateKey' + +-- | Get the specified key as an unboxed byte array. +-- Only the bytes of the key itself are returned; exported keys do not +-- include information about which cipher they are for. +getKeyBytes :: MonadConc m => SymmetricKey -> m (UArray Word32 Word8) +getKeyBytes = promise . keyBytes' + +-- | Import a key from an unboxed byte array. +keyFromBytes :: MonadConc m => Cipher -> UArray Word32 Word8 -> m (Either JSString SymmetricKey) +keyFromBytes c k = promiseE $ keyFromBytes' c k + +-- | Encrypt a message using the given cipher, key and initialization vector. +encryptUArray :: (Ix i, ArrView e, MonadConc m) + => SymmetricKey -> IV -> UArray i e -> m (UArray Word32 Word8) +encryptUArray k iv msg = promise (encrypt' k iv msg) + +-- | Encrypt a message using the given cipher, key and initialization vector. +decryptUArray :: (Ix i, ArrView e, MonadConc m) + => SymmetricKey -> IV -> UArray i e -> m (Either JSString (UArray Word32 Word8)) +decryptUArray k iv msg = promiseE $ decrypt' k iv msg + +-- | Encrypt a message using a custom initialization vector. The IV will +-- not be prepended to the output. +encryptWithIV :: (Binary a, MonadConc m) + => IV + -> SymmetricKey + -> a + -> m Blob +encryptWithIV iv k val = do + msg <- getBlobData $ encode val + fromUArray <$> encryptUArray k iv (toUArray msg :: UArray Word32 Word8) + +-- | Decrypt a message using a custom initialization vector. +decryptWithIV :: (Binary a, MonadConc m) + => IV + -> SymmetricKey + -> Blob + -> m (Either JSString a) +decryptWithIV iv k blob = do + msg <- getBlobData blob + emsg' <- decryptUArray k iv (toUArray msg :: UArray Word32 Word8) + case emsg' of + Left err -> return $ Left err + Right msg' -> do + eres <- decodeBlob $ fromUArray msg' + case eres of + Right res -> return $ Right res + Left err -> return $ Left $ toJSString err + +-- | Generate an byte initialization vector of appropriate length for the +-- given cipher. +generateIV :: MonadIO m => Cipher -> m IV +generateIV = fmap IV . cryptoRandomUArray . ivLength + +-- | The default initialization vector length for the available ciphers. +ivLength :: Cipher -> Word32 +ivLength (AES CBC Bits128) = 16 +ivLength (AES CBC Bits256) = 32 +ivLength (AES GCM _) = 12 + +-- | Encrypt and encrypt a 'Binary' value using a random initialization vector. +-- The IV will be prepended to the message; when using GCM mode, the IV will +-- be 12 bytes, otherwise it will match the length of the key. +-- +-- An unboxed array can be obtained from the +-- resulting 'Blob': +-- +-- toUArray <$> getBlobData blob +encrypt :: (Binary a, MonadConc m) + => SymmetricKey + -> a + -> m Blob +encrypt k msg = do + iv <- generateIV (keyCipher k) + msg' <- encryptWithIV iv k msg + let derp = runPut (putBlob (fromUArray (ivBytes iv)) >> putBlob msg') + return derp + +-- | Decrypt and decode a 'Binary' value from a 'Blob'. The initialization +-- vector will be read from the beginning of the message; see 'encrypt' for +-- information about IV lengths. +-- A blob can be obtained from an unboxed array using 'fromUArray'. +decrypt :: (Binary a, MonadConc m) + => SymmetricKey + -> Blob + -> m (Either JSString a) +decrypt k blob = do + bd <- getBlobData blob + case (getIV bd, getMsg bd) of + (Left e, _) -> return $ Left $ catJSStr "" ["couldn't read IV: ", e] + (_, Left e) -> return $ Left $ catJSStr "" ["couldn't read data: ", e] + (Right iv, Right msg) -> do + emsg' <- decryptUArray k (IV $ toUArray iv) (toUArray msg :: UArray Word32 Word8) + case emsg' of + Left err -> return $ Left $ catJSStr "" ["decryption failed: ", err] + Right msg' -> do + eres <- decodeBlob $ fromUArray msg' + case eres of + Left err -> return $ Left $ catJSStr "" ["couldn't parse value: ", err] + Right res -> return $ Right res + where + ivLen = fromIntegral $ ivLength (keyCipher k) + getIV = runGet $ getBytes ivLen + getMsg = runGet $ skip ivLen >> getBytes (blobSize blob - ivLen) + +-- | Derive a key from the given password and salt, using the PBKDF2 key +-- derivation over SHA-256, with the given number of iterations. +-- +-- One million iterations take roughly half a second on a modern laptop. +-- Returns @Nothing@ on browsers where the operation is not supported. +-- Presently not supported by IE/Edge. +deriveKey :: MonadConc m => Cipher -> Int -> Salt -> Password -> m (Maybe SymmetricKey) +deriveKey c n s pass = promise $ deriveKey' c s n (encodeUtf8 pass) + +encodeUtf8 :: JSString -> UArray Word32 Word8 +encodeUtf8 = unsafePerformIO . encodeUtf8' diff --git a/src/Haste/Crypto/Prim.hs b/src/Haste/Crypto/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Crypto/Prim.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE OverloadedStrings #-} +module Haste.Crypto.Prim where +import Haste +import Haste.Foreign +import Haste.Crypto.Types +import Data.Array.Unboxed +import Data.Array.IO +import Data.Word +import Haste.Concurrent + +-- | Fill the given array with random bits, using the browser's @window.crypto@ +-- object. +randomBits :: ArrView e => IOUArray Word32 e -> IO () +randomBits = ffi "(function(arr){window['__haste_crypto'].getRandomValues(arr);})" + +-- | Wait for a promise to either complete or get rejected. Promises used with +-- this function should not get rejected unless there is a bug in this very +-- library. +-- Promises that may fail for normal reasons should not use this function. +promise :: MonadConc m + => ((a -> IO ()) -> (JSString -> IO ()) -> IO ()) + -> m a +promise f = liftCIO $ do + res <- promiseE f + case res of + Right x -> return x + Left e -> error ("promise rejected: " ++ fromJSStr e) + +-- | A promise that might fail. +promiseE :: MonadConc m + => ((a -> IO ()) -> (JSString -> IO ()) -> IO ()) + -> m (Either JSString a) +promiseE f = liftCIO $ do + v <- newEmptyMVar + liftIO $ f (concurrent . putMVar v . Right) (concurrent . putMVar v . Left) + takeMVar v + +generateKey' :: Cipher -> (SymmetricKey -> IO ()) -> (JSString -> IO ()) -> IO () +generateKey' = ffi "(function(c, yay, nay) {\ + \window['__haste_crypto'].subtle.generateKey(c, true, ['encrypt','decrypt'])\ + \.then(function(k) {yay({key: k, cipher: c});})\ + \.catch(nay);\ + \})" + +encrypt' :: (Ix i, ArrView e) + => SymmetricKey -> IV -> UArray i e + -> (UArray Word32 Word8 -> IO ()) + -> (JSString -> IO ()) + -> IO () +encrypt' = ffi "(function(k, iv, data, yay, nay) {\ + \k.cipher.iv = iv;\ + \window['__haste_crypto'].subtle.encrypt(k.cipher, k.key, data)\ + \.then(function(enc){yay(new Uint8Array(enc));})\ + \.catch(nay);\ + \})" + +decrypt' :: (Ix i, ArrView e) + => SymmetricKey -> IV -> UArray i e + -> (UArray Word32 Word8 -> IO ()) + -> (JSString -> IO ()) + -> IO () +decrypt' = ffi "(function(k, iv, data, yay, nay) {\ + \k.cipher.iv = iv;\ + \window['__haste_crypto'].subtle.decrypt(k.cipher, k.key, data)\ + \.then(function(dec){yay(new Uint8Array(dec));})\ + \.catch(nay);\ + \})" + +keyBytes' :: SymmetricKey + -> (UArray Word32 Word8 -> IO ()) + -> (JSString -> IO ()) + -> IO () +keyBytes' = ffi "(function(k, yay, nay){\ + \window['__haste_crypto'].subtle.exportKey('raw', k.key)\ + \.then(function(dec){yay(new Uint8Array(dec));})\ + \.catch(nay);\ + \})" + +keyFromBytes' :: Cipher + -> UArray Word32 Word8 + -> (SymmetricKey -> IO ()) + -> (JSString -> IO ()) + -> IO () +keyFromBytes' = ffi "(function(alg, k, yay, nay){\ + \window['__haste_crypto'].subtle.importKey('raw', k, alg, true, ['encrypt', 'decrypt'])\ + \.then(function(k) {yay({key: k, cipher: alg});})\ + \.catch(nay);\ + \})" + +deriveKey' :: Cipher -> Salt -> Int -> UArray Word32 Word8 -> (Maybe SymmetricKey -> IO ()) -> (JSString -> IO ()) -> IO () +deriveKey' = ffi "(function(alg, s, n, k, yay, nay){\ + \window['__haste_crypto'].subtle.importKey('raw', k, {name:'PBKDF2'}, false, ['deriveKey']).then(function(mk) {\ + \window['__haste_crypto'].subtle.deriveKey({name:'PBKDF2',salt:s,iterations:n,hash:'SHA-256'}, mk, alg, true, ['encrypt', 'decrypt']).then(function(k){yay({key: k, cipher: alg});}).catch(function(_){yay(null);});\ + \});})" + +encodeUtf8' :: JSString -> IO (UArray Word32 Word8) +encodeUtf8' = ffi "(function(s){\ + \s = unescape(encodeURIComponent(s));\ + \var arr = new Uint8Array(s.length);\ + \for(var i = 0 ; i < s.length; ++i) {\ + \ arr[i] = s.charCodeAt(i);\ + \}\ + \return arr;\ + \})" diff --git a/src/Haste/Crypto/Types.hs b/src/Haste/Crypto/Types.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Crypto/Types.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-} +module Haste.Crypto.Types where +import Haste (JSString, JSType (..)) +import Haste.Binary as B +import Haste.Foreign as F +import Data.Array.Unboxed +import Data.Word + +-- | Denotes a block cipher mode. As only CBC and GCM are universally supported +-- by browsers, these are presently the only modes exported by Haste. +-- If unsure, always use @GCM@. +data CipherMode = CBC | GCM + deriving (Show, Read, Eq, Ord) + +data KeyLength = Bits128 | Bits256 + deriving (Show, Read, Eq, Ord) + +data Cipher = AES CipherMode KeyLength + deriving (Show, Read, Eq, Ord) + +-- | A key for a symmetric cipher. +data SymmetricKey = SymmetricKey JSAny Cipher + +keyCipher :: SymmetricKey -> Cipher +keyCipher (SymmetricKey _ c) = c + +instance ToAny SymmetricKey where + toAny (SymmetricKey k c) = toObject [("key", k), ("cipher", toAny c)] + +instance FromAny SymmetricKey where + fromAny x = SymmetricKey <$> F.get x "key" <*> F.get x "cipher" + +newtype IV = IV {ivBytes :: UArray Word32 Word8} + deriving (ToAny, FromAny, Binary) + +newtype Salt = Salt {saltBytes :: UArray Word32 Word8} + deriving (ToAny, FromAny, Binary) + +type Password = JSString + +instance Binary CipherMode where + put CBC = putWord8 0 + put GCM = putWord8 1 + get = do + n <- getWord8 + case n of + 0 -> pure CBC + 1 -> pure GCM + _ -> fail "Cipher mode was neither CBC nor GCM" + +instance Binary KeyLength where + put Bits128 = putWord8 0 + put Bits256 = putWord8 1 + get = do + n <- getWord8 + case n of + 0 -> pure Bits128 + 1 -> pure Bits256 + _ -> fail "Key length was neither 128 nor 256 bits" + +instance Binary Cipher where + put (AES mode len) = putWord8 0 >> put mode >> put len + get = do + n <- getWord8 + case n of + 0 -> AES <$> B.get <*> B.get + _ -> fail "Invalid cipher" + +instance ToAny CipherMode where + toAny = toAny . toJSString + +instance ToAny KeyLength where + toAny = toAny . toJSString + +instance FromAny CipherMode where + fromAny x = do + s <- fromAny x + maybe (fail "Unable to read CipherMode") return (fromJSString s) + +instance FromAny KeyLength where + fromAny x = do + s <- fromAny x + maybe (fail "Unable to read KeyLength") return (fromJSString s) + +instance JSType KeyLength where + toJSString Bits128 = "128" + toJSString Bits256 = "256" + fromJSString "128" = Just Bits128 + fromJSString "256" = Just Bits256 + fromJSString _ = Nothing + +instance ToAny Cipher where + toAny (AES mode len) = toObject + [ ("name", toAny mode) + , ("length", toAny len) + ] + +instance FromAny Cipher where + fromAny x = AES <$> F.get x "name" <*> F.get x "length" + +instance JSType CipherMode where + toJSString CBC = "AES-CBC" + toJSString GCM = "AES-GCM" + + fromJSString "AES-CBC" = Just CBC + fromJSString "AES-GCM" = Just GCM + fromJSString _ = Nothing diff --git a/src/Haste/DOM.hs b/src/Haste/DOM.hs new file mode 100644 --- /dev/null +++ b/src/Haste/DOM.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE GADTs #-} +-- | DOM manipulation functions using 'String' for string representation. +module Haste.DOM ( + -- * Basic types and elements + IsElem (..), Elem (..), + document, documentBody, documentHead, + + -- * Adding and removing child elements + appendChild, insertChildBefore, setChildren, clearChildren, deleteChild, + + -- * Selecting child elements + getFirstChild, getLastChild, getChildren, + + -- * Creating elements + newElem, newTextElem, + + -- * Setting attributes on elements + Attribute, AttrValue, AttrName (..), + attribute, set, with, children, + prop, style, attr, (=:), + + -- * Selecting elements + QuerySelector, ElemID, + elemById, elemsByQS, elemsByClass, + withElem , withElems, withElemsQS, mapQS, mapQS_, + + -- * Properties and attributes + PropID, + setProp, unsetProp, getProp, setAttr, unsetAttr, getAttr, J.getValue, + + -- * Style sheets and classes + ElemClass, getStyle, setStyle, setClass, toggleClass, hasClass, + addStylesheet, + + -- * Triggering events + click, focus, blur, + + -- * File elements + J.getFileData, getFileName, + ) where +import qualified Haste.DOM.JSString as J +import Haste.DOM.Core +import Haste.Prim (fromJSStr, toJSStr) +import Control.Monad.IO.Class + +type PropID = String +type ElemID = String +type QuerySelector = String +type ElemClass = String +type AttrValue = String + +-- | Create a style attribute name. +style :: String -> AttrName +style = StyleName . toJSStr + +-- | Create an HTML attribute name. +attr :: String -> AttrName +attr = AttrName . toJSStr + +-- | Create a DOM property name. +-- See for more information about the difference between attributes and properties. +prop :: String -> AttrName +prop = PropName . toJSStr + +-- | Create an 'Attribute'. +(=:) :: AttrName -> AttrValue -> Attribute +name =: val = attribute name (toJSStr val) + +-- | Create an element. +newElem :: MonadIO m => String -> m Elem +newElem = J.newElem . toJSStr + +-- | Create a text node. +newTextElem :: MonadIO m => String -> m Elem +newTextElem = J.newTextElem . toJSStr + +-- | Set a property of the given element. +setProp :: (IsElem e, MonadIO m) => e -> PropID -> String -> m () +setProp e property val = J.setProp e (toJSStr property) (toJSStr val) + +-- | Unset a property of the given element. Primarily useful with boolean +-- properties. +unsetProp :: (IsElem e, MonadIO m) => e -> PropID -> m () +unsetProp e property = J.unsetProp e (toJSStr property) + +-- | Set an attribute of the given element. +setAttr :: (IsElem e, MonadIO m) => e -> PropID -> String -> m () +setAttr e property val = J.setAttr e (toJSStr property) (toJSStr val) + +-- | Unset an attribute of the given element. Primarily useful with boolean +-- attributes. +unsetAttr :: (IsElem e, MonadIO m) => e -> PropID -> m () +unsetAttr e property = J.unsetAttr e (toJSStr property) + +-- | Get a property of an element. +getProp :: (IsElem e, MonadIO m) => e -> PropID -> m String +getProp e property = J.getProp e (toJSStr property) >>= return . fromJSStr + +-- | Get an attribute of an element. +getAttr :: (IsElem e, MonadIO m) => e -> PropID -> m String +getAttr e property = J.getAttr e (toJSStr property) >>= return . fromJSStr + +-- | Get a CSS style property of an element. +getStyle :: (IsElem e, MonadIO m) => e -> PropID -> m String +getStyle e property = J.getStyle e (toJSStr property) >>= return . fromJSStr + +-- | Set a CSS style property on an element. +setStyle :: (IsElem e, MonadIO m) => e -> PropID -> String -> m () +setStyle e property val = J.setStyle e (toJSStr property) (toJSStr val) + +-- | Get an element by its HTML ID attribute. +elemById :: MonadIO m => ElemID -> m (Maybe Elem) +elemById = J.elemById . toJSStr + +-- | Get all elements of the given class. +elemsByClass :: MonadIO m => ElemClass -> m [Elem] +elemsByClass = J.elemsByClass . toJSStr + +-- | Get all children elements matching a query selector. +elemsByQS :: MonadIO m => Elem -> QuerySelector -> m [Elem] +elemsByQS el = J.elemsByQS el . toJSStr + +-- | Perform an IO action on an element. +withElem :: MonadIO m => ElemID -> (Elem -> m a) -> m a +withElem = J.withElem . toJSStr + +-- | Perform an IO action over several elements. Throws an error if some of the +-- elements are not found. +withElems :: MonadIO m => [ElemID] -> ([Elem] -> m a) -> m a +withElems = J.withElems . map toJSStr + +-- | Perform an IO action over the a list of elements matching a query +-- selector. +withElemsQS :: (IsElem e, MonadIO m) + => e + -> QuerySelector + -> ([Elem] -> m a) + -> m a +withElemsQS el = J.withElemsQS el . toJSStr + +-- | Map an IO computation over the list of elements matching a query selector. +mapQS :: (IsElem e, MonadIO m) + => e + -> QuerySelector + -> (Elem -> m a) + -> m [a] +mapQS el = J.mapQS el . toJSStr + +-- | Like @mapQS@ but returns no value. +mapQS_ :: (IsElem e, MonadIO m) + => e + -> QuerySelector + -> (Elem -> m a) + -> m () +mapQS_ el = J.mapQS_ el . toJSStr + +-- | Get the name of the currently selected file from a file input element. +-- Any directory information is stripped, and only the actual file name is +-- returned, as the directory information is useless (and faked) anyway. +getFileName :: (IsElem e, MonadIO m) => e -> m String +getFileName e = J.getFileName e >>= return . fromJSStr + +-- | Add or remove a class from an element's class list. +setClass :: (IsElem e, MonadIO m) => e -> String -> Bool -> m () +setClass e sel = J.setClass e (toJSStr sel) + +-- | Toggle the existence of a class within an elements class list. +toggleClass :: (IsElem e, MonadIO m) => e -> String -> m () +toggleClass e = J.toggleClass e . toJSStr + +-- | Does the given element have a particular class? +hasClass :: (IsElem e, MonadIO m) => e -> String -> m Bool +hasClass e = J.hasClass e . toJSStr + +-- | Append the stylesheet at the given URL to @document.head@. +addStylesheet :: MonadIO m => String -> m () +addStylesheet = J.addStylesheet . toJSStr diff --git a/src/Haste/DOM/Core.hs b/src/Haste/DOM/Core.hs new file mode 100644 --- /dev/null +++ b/src/Haste/DOM/Core.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, OverloadedStrings #-} +-- | Core types and operations for DOM manipulation. +module Haste.DOM.Core ( + Elem (..), IsElem (..), Attribute, AttrName (..), + set, with, attribute, children, + click, focus, blur, + document, documentBody, documentHead, + deleteChild, clearChildren, + setChildren, getChildren, + getLastChild, getFirstChild, getChildBefore, + insertChildBefore, appendChild, + -- Low level stuff + jsSet, jsSetAttr, jsSetStyle, jsUnset, jsUnsetAttr, + ) where +import Haste.Prim +import Control.Monad.IO.Class +import Haste.Prim.Foreign +import Data.String + +jsSet :: Elem -> JSString -> JSString -> IO () +jsSet = ffi "(function(e,p,v){e[p] = v;})" + +jsUnset :: Elem -> JSString -> IO () +jsUnset = ffi "(function(e,p){delete e[p];})" + +jsSetAttr :: Elem -> JSString -> JSString -> IO () +jsSetAttr = ffi "(function(e,p,v){e.setAttribute(p, v);})" + +jsUnsetAttr :: Elem -> JSString -> IO () +jsUnsetAttr = ffi "(function(e,p){e.removeAttribute(p);})" + +jsSetStyle :: Elem -> JSString -> JSString -> IO () +jsSetStyle = ffi "(function(e,p,v){e.style[p] = v;})" + +jsAppendChild :: Elem -> Elem -> IO () +jsAppendChild = ffi "(function(c,p){p.appendChild(c);})" + +jsGetFirstChild :: Elem -> IO (Maybe Elem) +jsGetFirstChild = ffi "(function(e){\ +for(e = e.firstChild; e != null; e = e.nextSibling)\ + {if(e instanceof HTMLElement) {return e;}}\ +return null;})" + +jsGetLastChild :: Elem -> IO (Maybe Elem) +jsGetLastChild = ffi "(function(e){\ +for(e = e.lastChild; e != null; e = e.previousSibling)\ + {if(e instanceof HTMLElement) {return e;}}\ +return null;})" + +jsGetChildren :: Elem -> IO [Elem] +jsGetChildren = ffi "(function(e){\ +var ch = [];\ +for(e = e.firstChild; e != null; e = e.nextSibling)\ + {if(e instanceof HTMLElement) {ch.push(e);}}\ +return ch;})" + +jsSetChildren :: Elem -> [Elem] -> IO () +jsSetChildren = ffi "(function(e,ch){\ +while(e.firstChild) {e.removeChild(e.firstChild);}\ +for(var i in ch) {e.appendChild(ch[i]);}})" + +jsAddChildBefore :: Elem -> Elem -> Elem -> IO () +jsAddChildBefore = ffi "(function(c,p,a){p.insertBefore(c,a);})" + +jsGetChildBefore :: Elem -> IO (Maybe Elem) +jsGetChildBefore = ffi "(function(e){\ +for(; e != null; e = e.previousSibling)\ + {if(e instanceof HTMLElement) {return e;}\ +return null;})" + +jsKillChild :: Elem -> Elem -> IO () +jsKillChild = ffi "(function(c,p){p.removeChild(c);})" + +jsClearChildren :: Elem -> IO () +jsClearChildren = ffi "(function(e){\ +while(e.firstChild){e.removeChild(e.firstChild);}})" + +-- | A DOM node. +newtype Elem = Elem JSAny + deriving (ToAny, FromAny) + +-- | The class of types backed by DOM elements. +class IsElem a where + -- | Get the element representing the object. + elemOf :: a -> Elem + + -- | Attempt to create a DOM element backed object from an 'Elem'. + -- The default instance always returns @Nothing@. + fromElem :: MonadIO m => Elem -> m (Maybe a) + fromElem = const $ return Nothing + +instance IsElem Elem where + elemOf = id + fromElem = return . Just + +-- | The name of an attribute. May be either a common property, an HTML +-- attribute or a style attribute. +data AttrName + = PropName !JSString + | StyleName !JSString + | AttrName !JSString + deriving (Eq, Ord) + +instance IsString AttrName where + fromString = PropName . fromString + +-- | A key/value pair representing the value of an attribute. +-- May represent a property, an HTML attribute, a style attribute or a list +-- of child elements. +data Attribute + = Attribute !AttrName !JSString + | Children ![Elem] + +-- | Construct an 'Attribute'. +attribute :: AttrName -> JSString -> Attribute +attribute = Attribute + +-- | Set a number of 'Attribute's on an element. +set :: (IsElem e, MonadIO m) => e -> [Attribute] -> m () +set e as = + liftIO $ mapM_ set' as + where + e' = elemOf e + set' (Attribute (PropName k) v) = jsSet e' k v + set' (Attribute (StyleName k) v) = jsSetStyle e' k v + set' (Attribute (AttrName k) v) = jsSetAttr e' k v + set' (Children cs) = mapM_ (flip jsAppendChild e') cs + +-- | Attribute adding a list of child nodes to an element. +children :: [Elem] -> Attribute +children = Children + +-- | Set a number of 'Attribute's on the element produced by an IO action. +-- Gives more convenient syntax when creating elements: +-- +-- > newElem "div" `with` [ +-- > style "border" =: "1px solid black", +-- > ... +-- > ] +-- +with :: (IsElem e, MonadIO m) => m e -> [Attribute] -> m e +with m attrs = do + x <- m + set x attrs + return x + +-- | Generate a click event on an element. +click :: (IsElem e, MonadIO m) => e -> m () +click = liftIO . click' . elemOf + +click' :: Elem -> IO () +click' = ffi "(function(e) {e.click();})" + +-- | Generate a focus event on an element. +focus :: (IsElem e, MonadIO m) => e -> m () +focus = liftIO . focus' . elemOf + +focus' :: Elem -> IO () +focus' = ffi "(function(e) {e.focus();})" + +-- | Generate a blur event on an element. +blur :: (IsElem e, MonadIO m) => e -> m () +blur = liftIO . blur' . elemOf + +blur' :: Elem -> IO () +blur' = ffi "(function(e) {e.blur();})" + +-- | The DOM node corresponding to @document@. +document :: Elem +document = constant "document" + +-- | The DOM node corresponding to @document.body@. +documentBody :: Elem +documentBody = constant "document.body" + +-- | The DOM node corresponding to @document.head@. +documentHead :: Elem +documentHead = constant "document.body" + +-- | Append the second element as a child of the first. +appendChild :: (IsElem parent, IsElem child, MonadIO m) => parent -> child -> m () +appendChild parent child = liftIO $ jsAppendChild (elemOf child) (elemOf parent) + +-- | Insert an element into a container, before another element. +-- For instance: +-- @ +-- insertChildBefore theContainer olderChild childToAdd +-- @ +insertChildBefore :: (IsElem parent, IsElem before, IsElem child, MonadIO m) + => parent -> before -> child -> m () +insertChildBefore parent oldChild child = + liftIO $ jsAddChildBefore (elemOf child) (elemOf parent) (elemOf oldChild) + +-- | Get the sibling before the given one, if any. +getChildBefore :: (IsElem e, MonadIO m) => e -> m (Maybe Elem) +getChildBefore e = liftIO $ jsGetChildBefore (elemOf e) + +-- | Get the first of an element's children. +getFirstChild :: (IsElem e, MonadIO m) => e -> m (Maybe Elem) +getFirstChild e = liftIO $ jsGetFirstChild (elemOf e) + +-- | Get the last of an element's children. +getLastChild :: (IsElem e, MonadIO m) => e -> m (Maybe Elem) +getLastChild e = liftIO $ jsGetLastChild (elemOf e) + +-- | Get a list of all children belonging to a certain element. +getChildren :: (IsElem e, MonadIO m) => e -> m [Elem] +getChildren e = liftIO $ jsGetChildren (elemOf e) + +-- | Clear the given element's list of children, and append all given children +-- to it. +setChildren :: (IsElem parent, IsElem child, MonadIO m) + => parent + -> [child] + -> m () +setChildren e ch = liftIO $ jsSetChildren (elemOf e) (map elemOf ch) + +-- | Remove all children from the given element. +clearChildren :: (IsElem e, MonadIO m) => e -> m () +clearChildren = liftIO . jsClearChildren . elemOf + +-- | Remove the second element from the first's children. +deleteChild :: (IsElem parent, IsElem child, MonadIO m) + => parent + -> child + -> m () +deleteChild parent child = liftIO $ jsKillChild (elemOf child) (elemOf parent) diff --git a/src/Haste/DOM/JSString.hs b/src/Haste/DOM/JSString.hs new file mode 100644 --- /dev/null +++ b/src/Haste/DOM/JSString.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | DOM manipulation functions using 'JSString' for string representation. +module Haste.DOM.JSString ( + -- * Basic types and elements + IsElem (..), Elem (..), + document, documentBody, documentHead, + + -- * Adding and removing child elements + appendChild, insertChildBefore, setChildren, clearChildren, deleteChild, + + -- * Selecting child elements + getFirstChild, getLastChild, getChildren, + + -- * Creating elements + newElem, newTextElem, + + -- * Setting attributes on elements + Attribute, AttrValue, AttrName (..), + attribute, set, with, children, + prop, style, attr, (=:), + + -- * Selecting elements + QuerySelector, ElemID, + elemById, elemsByQS, elemsByClass, + withElem , withElems, withElemsQS, mapQS, mapQS_, + + -- * Properties and attributes + PropID, + setProp, unsetProp, getProp, setAttr, unsetAttr, getAttr, getValue, + + -- * Style sheets and classes + ElemClass, getStyle, setStyle, setClass, toggleClass, hasClass, + addStylesheet, + + -- * Triggering events + click, focus, blur, + + -- * File elements + getFileData, getFileName, + ) where +import Haste.Prim +import Haste.Prim.JSType +import Haste.DOM.Core +import Data.Maybe (isNothing, fromJust) +import Control.Monad.IO.Class +import Haste.Prim.Foreign +import Haste.Binary.Types + +type PropID = JSString +type ElemID = JSString +type QuerySelector = JSString +type ElemClass = JSString +type AttrValue = JSString + +jsGet :: Elem -> JSString -> IO JSString +jsGet = ffi "(function(e,p){var x = e[p];\ + \return typeof x === 'undefined' ? '' : x.toString();})" + +jsGetAttr :: Elem -> JSString -> IO JSString +jsGetAttr = ffi "(function(e,p){\ +\return e.hasAttribute(p) ? e.getAttribute(p) : '';})" + +jsGetStyle :: Elem -> JSString -> IO JSString +jsGetStyle = ffi "(function(e,p){var x = e.style[p];\ + \return typeof x === 'undefined' ? '' : x.toString();})" + +jsFind :: JSString -> IO (Maybe Elem) +jsFind = ffi "(function(id){return document.getElementById(id);})" + +jsQuerySelectorAll :: Elem -> JSString -> IO [Elem] +jsQuerySelectorAll = ffi "(function(e,q){\ + \if(!e || typeof e.querySelectorAll !== 'function') {\ + \throw 'querySelectorAll not supported by this element';\ + \} else {\ + \return e.querySelectorAll(q);\ + \}})" + +jsElemsByClassName :: JSString -> IO [Elem] +jsElemsByClassName = ffi "(function(c){\ +\return document.getElementsByClassName(c);})" + +jsCreateElem :: JSString -> IO Elem +jsCreateElem = ffi "(function(t){return document.createElement(t);})" + +jsCreateTextNode :: JSString -> IO Elem +jsCreateTextNode = ffi "(function(s){return document.createTextNode(s);})" + +-- | Create a style attribute name. +style :: JSString -> AttrName +style = StyleName + +-- | Create an HTML attribute name. +attr :: JSString -> AttrName +attr = AttrName + +-- | Create a DOM property name. +-- See for more information about the difference between attributes and properties. +prop :: JSString -> AttrName +prop = PropName + +-- | Create an 'Attribute'. +infixl 4 =: +(=:) :: AttrName -> AttrValue -> Attribute +(=:) = attribute + +-- | Create an element. +newElem :: MonadIO m => JSString -> m Elem +newElem = liftIO . jsCreateElem + +-- | Create a text node. +newTextElem :: MonadIO m => JSString -> m Elem +newTextElem = liftIO . jsCreateTextNode + +-- | Set a property of the given element. +setProp :: (IsElem e, MonadIO m) => e -> PropID -> JSString -> m () +setProp e property val = liftIO $ jsSet (elemOf e) property val + +-- | Unset a property of the given element. Primarily useful with boolean +-- properties. +unsetProp :: (IsElem e, MonadIO m) => e -> PropID -> m () +unsetProp e property = liftIO $ jsUnset (elemOf e) property + +-- | Set an attribute of the given element. +setAttr :: (IsElem e, MonadIO m) => e -> PropID -> JSString -> m () +setAttr e property val = liftIO $ jsSetAttr (elemOf e) property val + +-- | Unset an attribute of the given element. Primarily useful with boolean +-- attributes. +unsetAttr :: (IsElem e, MonadIO m) => e -> PropID -> m () +unsetAttr e property = liftIO $ jsUnsetAttr (elemOf e) property + +-- | Get the value property of an element; a handy shortcut. +getValue :: (IsElem e, MonadIO m, JSType a) => e -> m (Maybe a) +getValue e = liftIO $ fromJSString `fmap` jsGet (elemOf e) "value" + +-- | Get a property of an element. +getProp :: (IsElem e, MonadIO m) => e -> PropID -> m JSString +getProp e property = liftIO $ jsGet (elemOf e) property + +-- | Get an attribute of an element. +getAttr :: (IsElem e, MonadIO m) => e -> PropID -> m JSString +getAttr e property = liftIO $ jsGetAttr (elemOf e) property + +-- | Get a CSS style property of an element. +getStyle :: (IsElem e, MonadIO m) => e -> PropID -> m JSString +getStyle e property = liftIO $ jsGetStyle (elemOf e) property + +-- | Set a CSS style property on an element. +setStyle :: (IsElem e, MonadIO m) => e -> PropID -> JSString -> m () +setStyle e property val = liftIO $ jsSetStyle (elemOf e) property val + +-- | Get an element by its HTML ID attribute. +elemById :: MonadIO m => ElemID -> m (Maybe Elem) +elemById eid = liftIO $ jsFind eid + +-- | Get all elements of the given class. +elemsByClass :: MonadIO m => ElemClass -> m [Elem] +elemsByClass cls = liftIO $ jsElemsByClassName cls + +-- | Get all children elements matching a query selector. +elemsByQS :: (IsElem e, MonadIO m) => e -> QuerySelector -> m [Elem] +elemsByQS el sel = liftIO $ jsQuerySelectorAll (elemOf el) sel + +-- | Perform an IO action on an element. +withElem :: MonadIO m => ElemID -> (Elem -> m a) -> m a +withElem e act = do + me' <- elemById e + case me' of + Just e' -> act e' + _ -> error $ "No element with ID " ++ fromJSStr e ++ " found!" + +-- | Perform an IO action over several elements. Throws an error if some of the +-- elements are not found. +withElems :: MonadIO m => [ElemID] -> ([Elem] -> m a) -> m a +withElems es act = do + mes <- mapM elemById es + if any isNothing mes + then error $ "Elements with the following IDs could not be found: " + ++ show (findElems es mes) + else act $ map fromJust mes + where + findElems (i:is) (Nothing:mes) = i : findElems is mes + findElems (_:is) (_:mes) = findElems is mes + findElems _ _ = [] + +-- | Perform an IO action over the a list of elements matching a query +-- selector. +withElemsQS :: (IsElem e, MonadIO m) + => e + -> QuerySelector + -> ([Elem] -> m a) + -> m a +withElemsQS el sel act = elemsByQS el sel >>= act + +-- | Map an IO computation over the list of elements matching a query selector. +mapQS :: (IsElem e, MonadIO m) => e -> QuerySelector -> (Elem -> m a) -> m [a] +mapQS el sel act = elemsByQS el sel >>= mapM act + +-- | Like @mapQS@ but returns no value. +mapQS_ :: (IsElem e, MonadIO m) => e -> QuerySelector -> (Elem -> m a) -> m () +mapQS_ el sel act = elemsByQS el sel >>= mapM_ act + +-- | Get a file from a file input element. +getFileData :: (IsElem e, MonadIO m) => e -> Int -> m (Maybe Blob) +getFileData e ix = liftIO $ do + num <- getFiles (elemOf e) + if ix < num + then Just `fmap` getFile (elemOf e) ix + else return Nothing + +getFiles :: Elem -> IO Int +getFiles = ffi "(function(e){return e.files.length;})" + +getFile :: Elem -> Int -> IO Blob +getFile = ffi "(function(e,ix){return e.files[ix];})" + +-- | Get the name of the currently selected file from a file input element. +-- Any directory information is stripped, and only the actual file name is +-- returned, as the directory information is useless (and faked) anyway. +getFileName :: (IsElem e, MonadIO m) => e -> m JSString +getFileName e = liftIO $ do + fn <- fromJSStr `fmap` getProp e "value" + return $ toJSStr $ reverse $ takeWhile (not . separator) $ reverse fn + where + separator '/' = True + separator '\\' = True + separator _ = False + +-- | Add or remove a class from an element's class list. +setClass :: (IsElem e, MonadIO m) => e -> JSString -> Bool -> m () +setClass e c x = liftIO $ setc (elemOf e) c x + +setc :: Elem -> JSString -> Bool -> IO () +setc = ffi "(function(e,c,x){x?e.classList.add(c):e.classList.remove(c);})" + +-- | Toggle the existence of a class within an elements class list. +toggleClass :: (IsElem e, MonadIO m) => e -> JSString -> m () +toggleClass e c = liftIO $ toggc (elemOf e) c + +toggc :: Elem -> JSString -> IO () +toggc = ffi "(function(e,c) {e.classList.toggle(c);})" + +-- | Does the given element have a particular class? +hasClass :: (IsElem e, MonadIO m) => e -> JSString -> m Bool +hasClass e c = liftIO $ getc (elemOf e) c + +getc :: Elem -> JSString -> IO Bool +getc = ffi "(function(e,c) {return e.classList.contains(c);})" + +-- | Append the stylesheet at the given URL to @document.head@. +addStylesheet :: MonadIO m => JSString -> m () +addStylesheet url = do + e <- newElem "link" `with` [ "rel" =: "stylesheet", "href" =: url] + appendChild documentHead e diff --git a/src/Haste/Events.hs b/src/Haste/Events.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Events.hs @@ -0,0 +1,29 @@ +-- | Event handling for Haste. +module Haste.Events ( + -- * Core event functionality + Event (..), MonadEvent (..), + HandlerInfo, + unregisterHandler, onEvent, preventDefault, stopPropagation, + + -- * Basic events with no arguments + BasicEvent (..), + + -- * Keyboard-related events + KeyEvent (..), KeyData (..), mkKeyData, + + -- * Mouse-related events + MouseEvent (..), MouseData (..), MouseButton (..), + + -- * Touch-related events + TouchEvent (..), TouchData (..), Touch (..), + + -- * Messaging events and @postMessage@ API. + MessageEvent (..), MessageData (..), Window, Recipient (..), + window, getContentWindow, fromAny + ) where +import Haste.Events.Core as Core +import Haste.Events.BasicEvents as BasicEvents +import Haste.Events.KeyEvents as KeyEvents +import Haste.Events.MouseEvents as MouseEvents +import Haste.Events.TouchEvents as TouchEvents +import Haste.Events.MessageEvents as MessageEvents diff --git a/src/Haste/Events/BasicEvents.hs b/src/Haste/Events/BasicEvents.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Events/BasicEvents.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings, TypeFamilies #-} +-- | Basic events: load, unload, focus, submit, etc. +module Haste.Events.BasicEvents (BasicEvent (..)) where +import Haste.Events.Core + +data BasicEvent + = Load + | Unload + | Change + | Focus + | Blur + | Submit + | Scroll + | Input + +instance Event BasicEvent where + type EventData BasicEvent = () + eventName Load = "load" + eventName Unload = "unload" + eventName Change = "change" + eventName Focus = "focus" + eventName Blur = "blur" + eventName Submit = "submit" + eventName Scroll = "scroll" + eventName Input = "input" + eventData _ _ = return () diff --git a/src/Haste/Events/Core.hs b/src/Haste/Events/Core.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Events/Core.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts #-} +-- | Basic framework for event handling. +module Haste.Events.Core ( + Event (..), MonadEvent (..), EventSource (..), + HandlerInfo, + unregisterHandler, onEvent, preventDefault, stopPropagation + ) where +import Haste.Prim +import Haste.DOM.Core +import Haste.Prim.Foreign +import Control.Monad.IO.Class +import Data.IORef +import System.IO.Unsafe + +-- | Any type whose underlying DOM object can receive events. +class EventSource a where + eventSource :: a -> JSAny + +instance EventSource Elem where + eventSource (Elem e) = e + +-- | Any monad in which we're able to handle events. +class MonadIO m => MonadEvent m where + mkHandler :: (a -> m ()) -> m (a -> IO ()) + +instance MonadEvent IO where + mkHandler = return + +-- | Any type that describes an event. +class Event evt where + -- | The type of data to pass to handlers for this event. + type EventData evt + + -- | The name of this event, as expected by the DOM. + eventName :: evt -> JSString + + -- | Construct event data from the event identifier and the JS event object. + eventData :: evt -> JSAny -> IO (EventData evt) + +-- | Information about an event handler. +data HandlerInfo = HandlerInfo { + -- | Name of the handler's event. + handlerEvent :: JSString, + -- | Element the handler is set on. + handlerElem :: JSAny, + -- | Handle to handler function. + handlerFun :: JSAny + } + +-- | Unregister an event handler. +unregisterHandler :: MonadIO m => HandlerInfo -> m () +unregisterHandler (HandlerInfo ev el f) = liftIO $ unregEvt el ev f + +-- | Reference to the event currently being handled. +{-# NOINLINE evtRef #-} +evtRef :: IORef (Maybe JSAny) +evtRef = unsafePerformIO $ newIORef Nothing + +{-# INLINE setEvtRef #-} +setEvtRef :: JSAny -> IO () +setEvtRef = writeIORef evtRef . Just + +-- | Prevent the event being handled from resolving normally. +-- Does nothing if called outside an event handler. +preventDefault :: MonadIO m => m () +preventDefault = liftIO $ readIORef evtRef >>= preventDefault' + +preventDefault' :: Maybe JSAny -> IO () +preventDefault' = ffi "(function(e){if(e){e.preventDefault();}})" + +-- | Stop the event being handled from propagating. +-- Does nothing if called outside an event handler. +stopPropagation :: MonadIO m => m () +stopPropagation = liftIO $ readIORef evtRef >>= stopPropagation' + +stopPropagation' :: Maybe JSAny -> IO () +stopPropagation' = ffi "(function(e){if(e){e.stopPropagation();}})" + +-- | Set an event handler on a DOM element. +onEvent :: (MonadEvent m, EventSource el, Event evt) + => el -- ^ Element to set handler on. + -> evt -- ^ Event to handle. + -> (EventData evt -> m ()) -- ^ Event handler. + -> m HandlerInfo -- ^ Information about the handler. +onEvent el evt f = do + f' <- mkHandler $ \o -> prepareEvent o >>= f + hdl <- liftIO $ setEvt e name f' + return $ HandlerInfo { + handlerEvent = name, + handlerElem = e, + handlerFun = hdl + } + where + name = eventName evt + e = eventSource el + prepareEvent o = liftIO $ do + setEvtRef o + eventData evt o + +-- | Set an event handler on an element, returning a reference to the handler +-- exactly as seen by @addEventListener@. We can't reuse the reference to +-- the Haskell function as the FFI does some marshalling to functions, +-- meaning that the same function marshalled twice won't be reference equal +-- to each other. +setEvt :: JSAny -> JSString -> (JSAny -> IO ()) -> IO JSAny +setEvt = ffi "(function(e,name,f){e.addEventListener(name,f,false);\ + \return [f];})" + +-- | Unregister an event. +-- Note @f[0]@ and corresponding @[f]@ in 'setEvt'; this is a workaround for +-- a bug causing functions being packed into anything to be accidentally +-- called. Remove when properly fixed. +unregEvt :: JSAny -> JSString -> JSAny -> IO () +unregEvt = ffi "(function(e,name,f){e.removeEventListener(name,f[0]);})" diff --git a/src/Haste/Events/KeyEvents.hs b/src/Haste/Events/KeyEvents.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Events/KeyEvents.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings, TypeFamilies, CPP #-} +-- | Events relating to keyboard input. +module Haste.Events.KeyEvents (KeyEvent (..), KeyData (..), mkKeyData) where +import Haste.Prim.Any +import Haste.Events.Core + +-- | Event data for keyboard events. +data KeyData = KeyData { + keyCode :: !Int, + keyCtrl :: !Bool, + keyAlt :: !Bool, + keyShift :: !Bool, + keyMeta :: !Bool + } deriving (Show, Eq) + +-- | Build a 'KeyData' object for the given key, without any modifier keys +-- pressed. +mkKeyData :: Int -> KeyData +mkKeyData n = KeyData { + keyCode = fromIntegral n, + keyCtrl = False, + keyAlt = False, + keyShift = False, + keyMeta = False + } + +-- | Num instance for 'KeyData' to enable pattern matching against numeric +-- key codes. +instance Num KeyData where + fromInteger = mkKeyData . fromInteger + a + b = a {keyCode = keyCode a + keyCode b} + a * b = a {keyCode = keyCode a * keyCode b} + a - b = a {keyCode = keyCode a - keyCode b} + negate a = a {keyCode = negate $ keyCode a} + signum a = a {keyCode = signum $ keyCode a} + abs a = a {keyCode = abs $ keyCode a} + +data KeyEvent + = KeyPress + | KeyUp + | KeyDown + +instance Event KeyEvent where + type EventData KeyEvent = KeyData + eventName KeyPress = "keypress" + eventName KeyUp = "keyup" + eventName KeyDown = "keydown" + eventData _ e = + KeyData <$> get e "keyCode" + <*> get e "ctrlKey" + <*> get e "altKey" + <*> get e "shiftKey" + <*> get e "metaKey" diff --git a/src/Haste/Events/MessageEvents.hs b/src/Haste/Events/MessageEvents.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Events/MessageEvents.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings, TypeFamilies, GeneralizedNewtypeDeriving #-} +-- | Events relating to the @postMessage@ API for passing messages between +-- windows. +module Haste.Events.MessageEvents + ( MessageEvent (..) , MessageData (..), Recipient (..), Window + , getContentWindow, window, fromAny + ) where +import Control.Monad.IO.Class +import Haste.JSString (JSString) +import Haste.Prim.Foreign +import Haste.Events.Core +import Haste.DOM.Core (Elem (..)) + +-- | A DOM window. +newtype Window = Window JSAny + deriving (ToAny, FromAny, Eq) + +class Recipient a where + -- | Post a message to the given window. Messages are serialized using the + -- structured clone algorithm, meaning that you can post pretty much any + -- type of data, except functions, references and the like. + postMessage :: (ToAny msg, MonadIO m) => a -> msg -> m () + +instance Recipient Window where + postMessage wnd msg = liftIO $ postMessage' wnd (toAny msg) + +instance EventSource Window where + eventSource (Window e) = e + +-- | The window in which the program is executing. +window :: Window +window = constant "window" + +-- | Event data for keyboard events. +data MessageData = MessageData + { messageData :: !JSAny + , messageOrigin :: !JSString + , messageSource :: !Window + } + +data MessageEvent = Message + +instance Event MessageEvent where + type EventData MessageEvent = MessageData + eventName Message = "message" + eventData _ e = + MessageData <$> get e "data" + <*> get e "origin" + <*> get e "source" + +postMessage' :: Window -> JSAny -> IO () +postMessage' = ffi "(function(w,m){w.postMessage(m,'*');})" + +-- | Get the window object for an iframe. Must be called after the iframe is +-- attached to the DOM. +getContentWindow :: MonadIO m => Elem -> m (Maybe Window) +getContentWindow e = liftIO $ getContentWindow' e + +getContentWindow' :: Elem -> IO (Maybe Window) +getContentWindow' = ffi "(function(e){return e.contentWindow;})" diff --git a/src/Haste/Events/MouseEvents.hs b/src/Haste/Events/MouseEvents.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Events/MouseEvents.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings, TypeFamilies, TupleSections, CPP #-} +-- | Events relating to mouse clicks and movement. +module Haste.Events.MouseEvents ( + MouseEvent (..), MouseData (..), MouseButton (..) + ) where +import Haste.Events.Core +import Haste.Prim.Foreign + +data MouseButton = MouseLeft | MouseMiddle | MouseRight + deriving (Show, Eq, Enum) + +instance FromAny MouseButton where + fromAny = fmap toEnum . fromAny + +-- | Event data for mouse events. +data MouseData = MouseData { + -- | Mouse coordinates. + mouseCoords :: !(Int, Int), + -- | Pressed mouse button, if any. + mouseButton :: !(Maybe MouseButton), + -- | (x, y, z) mouse wheel delta. Always all zeroes except for 'Wheel'. + mouseWheelDeltas :: !(Double, Double, Double) + } + +data MouseEvent + = Click + | DblClick + | MouseDown + | MouseUp + | MouseMove + | MouseOver + | MouseOut + | Wheel + +instance Event MouseEvent where + type EventData MouseEvent = MouseData + eventName Click = "click" + eventName DblClick = "dblclick" + eventName MouseDown = "mousedown" + eventName MouseUp = "mouseup" + eventName MouseMove = "mousemove" + eventName MouseOver = "mouseover" + eventName MouseOut = "mouseout" + eventName Wheel = "wheel" + eventData Wheel e = + MouseData <$> jsGetMouseCoords e + <*> pure Nothing + <*> ((,,) <$> (get e "deltaX") + <*> (get e "deltaY") + <*> (get e "deltaZ")) + + eventData _ e = + MouseData <$> jsGetMouseCoords e + <*> get e "button" + <*> pure (0,0,0) + +jsGetMouseCoords :: JSAny -> IO (Int, Int) +jsGetMouseCoords = ffi "jsGetMouseCoords" diff --git a/src/Haste/Events/TouchEvents.hs b/src/Haste/Events/TouchEvents.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Events/TouchEvents.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings, TypeFamilies, CPP #-} +-- | Events relating to touch input. +module Haste.Events.TouchEvents ( + TouchEvent (..), TouchData (..), Touch (..) + ) where +import Haste.Prim.Any +import Haste.Prim.Foreign +import Haste.Events.Core +import Haste.DOM.Core + +data TouchEvent + = TouchStart + | TouchMove + | TouchEnd + | TouchCancel + +-- | Event data for touch events. +data TouchData = TouchData { + -- | All fingers currently on the screen. + touches :: [Touch], + + -- | All fingers on the DOM element receiving the event. + targetTouches :: [Touch], + + -- | All fingers involved in the current event. For instance, fingers + -- removed for the 'TouchEnd' event. + changedTouches :: [Touch] + } + +-- | A finger touching the screen. +data Touch = Touch { + -- | Unique identifier for this touch. + identifier :: !Int, + + -- | Target element of the touch. + target :: !Elem, + + -- | Page coordinates of the touch, including scroll offsets. + pageCoords :: !(Int, Int), + + -- | Page coordinates of the touch, excluding scroll offsets. + clientCoords :: !(Int, Int), + + -- | Screen coordinates of the touch. + screenCoords :: !(Int, Int) + } + +instance FromAny Touch where + fromAny t = + Touch <$> get t "identifier" + <*> get t "target" + <*> ((,) <$> get t "pageX" <*> get t "pageY") + <*> ((,) <$> get t "clientX" <*> get t "clientY") + <*> ((,) <$> get t "screenX" <*> get t "screenY") + +instance Event TouchEvent where + type EventData TouchEvent = TouchData + eventName TouchStart = "touchstart" + eventName TouchMove = "touchmove" + eventName TouchEnd = "touchend" + eventName TouchCancel = "touchcancel" + + eventData _ e = do + ts <- get e "touches" + (cts, tts) <- getTIDs e + return $ TouchData { + touches = ts, + changedTouches = filter ((`elem` cts) . identifier) ts, + targetTouches = filter ((`elem` tts) . identifier) ts + } + +-- | Get the touch IDs of all touches for changedTouches and targetTouches. +getTIDs :: JSAny -> IO ([Int], [Int]) +getTIDs = ffi "(function(e) {\ + var len = e.changedTouches.length;\ + var chts = new Array(len);\ + for(var i = 0; i < len; ++i) {chts[i] = e.changedTouches[i].identifier;}\ + var len = e.targetTouches.length;\ + var tts = new Array(len);\ + for(var i = 0; i < len; ++i) {tts[i] = e.targetTouches[i].identifier;}\ + return [chts, tts];})" diff --git a/src/Haste/Foreign.hs b/src/Haste/Foreign.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Foreign.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE CPP, OverloadedStrings #-} +-- | High level JavaScript foreign interface. +module Haste.Foreign + ( -- * Conversion to/from JSAny + ArrView, ToAny (..), FromAny (..), JSAny + , Opaque, toOpaque, fromOpaque + , nullValue, toObject, has, get, index, isUndefined + , getMaybe, hasAll, lookupAny, JSException (..) + + -- * Importing and exporting JavaScript functions + , FFI, JSFunc + , ffi, constant, export + , safe_ffi, StaticPtr + , withLibraries + ) where +import Haste.Prim.Foreign +import Haste.Prim (JSString) +import qualified Haste.JSString as J +import Control.Monad (foldM) + +-- For withLibraries +import Haste.Concurrent +import Haste.DOM.JSString +import Haste.Events + +-- For array instances +import Haste.Foreign.Array (ArrView) + +-- | Read a member from a JS object. Succeeds if the member exists. +getMaybe :: FromAny a => JSAny -> JSString -> IO (Maybe a) +getMaybe a k = do exists <- has a k + if exists then Just <$> get a k + else pure Nothing + +-- | Checks if a JS object has a list of members. Succeeds if the JS object +-- has every member given in the list. +hasAll :: JSAny -> [JSString] -> IO Bool +hasAll a ks = and <$> mapM (has a) ks + + +-- | Looks up an object by a `.`-separated string. Succeeds if the lowest +-- member exists. +-- +-- Usage example: +-- +-- >>> {'child': {'childrer': {'childerest': "I am very much a child."}}} +-- +-- Given the JS Object above, we can access the deeply nested object, +-- childerest, by lookupAny as in the below example +-- +-- >>> lookupAny jsObject "child.childrer.childerest" +lookupAny :: JSAny -> JSString -> IO (Maybe JSAny) +lookupAny root i = foldM hasGet (Just root) $ J.match dotsplit i + where hasGet Nothing _ = pure Nothing + hasGet (Just parent) ident = do h <- has parent ident + if h then Just <$> get parent ident + else pure Nothing + dotsplit = J.regex "[^.]+" "g" + +-- | Wait for the given libraries to load before executing the given +-- computation. Note that this function returns immediately, BEFORE the given +-- libraries are loaded. +withLibraries :: [JSString] -> IO () -> IO () +withLibraries libs m = concurrent $ do + vars <- mapM (const newEmptyMVar) libs + liftIO . sequence_ $ zipWith addLib libs vars + mapM_ takeMVar vars + liftIO m + where + addLib lib var = do + s <- newElem "SCRIPT" `with` ["src" =: lib] + s `onEvent` Load $ \_ -> concurrent $ putMVar var () + appendChild documentBody s diff --git a/src/Haste/Foreign/Array.hs b/src/Haste/Foreign/Array.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Foreign/Array.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, FlexibleContexts, FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Haste.Foreign.Array where +import Data.Array.IO hiding (index) +import Data.Array.Unboxed hiding (index) +import Data.Word +import Data.Int +import System.IO.Unsafe +import Haste.Prim +import Haste.Prim.Foreign + +-- Additional instances +iouarrToAny :: JSString -> Opaque (IOUArray i e) -> IO JSAny +iouarrToAny = ffi "(function(v,a){return a.d['v'][v];})" + +uarrToAny :: JSString -> Opaque (UArray i e) -> IO JSAny +uarrToAny = ffi "(function(v,a){return new a.d['v'][v].constructor(a.d['v'][v]);})" + +anyToIOUArr :: JSAny -> IO (Opaque (IOUArray i e)) +anyToIOUArr = ffi "(function(a){\ + \var arr = new ByteArray(a['buffer']);\ + \return new T4(0,0,a['length']-1,a['length'],arr);\ + \})" + +anyToUArr :: JSAny -> IO (Opaque (UArray i e)) +anyToUArr = ffi "(function(a){\ + \var arr = new ByteArray(new a.constructor(a['buffer']));\ + \return new T4(0,0,a['length']-1,a['length'],arr);\ + \})" + +class (IArray UArray a, MArray IOUArray a IO) => ArrView a where + arrView :: a -> JSString + +instance ArrView Double where arrView _ = "f64" +instance ArrView Float where arrView _ = "f32" +instance ArrView Int where arrView _ = "i32" +instance ArrView Int8 where arrView _ = "i8" +instance ArrView Int16 where arrView _ = "i16" +instance ArrView Int32 where arrView _ = "i32" +instance ArrView Word where arrView _ = "w32" +instance ArrView Word8 where arrView _ = "w8" +instance ArrView Word16 where arrView _ = "w16" +instance ArrView Word32 where arrView _ = "w32" + +instance ArrView e => FromAny (IOUArray i e) where + fromAny = fmap fromOpaque . anyToIOUArr + +instance forall i e. ArrView e => ToAny (IOUArray i e) where + toAny = unsafePerformIO . iouarrToAny (arrView (undefined :: e)) . toOpaque + +instance (Ix i, ArrView e) => FromAny (UArray i e) where + fromAny = fmap fromOpaque . anyToUArr + +instance forall i e. (Ix i, ArrView e) => ToAny (UArray i e) where + toAny = unsafePerformIO . uarrToAny (arrView (undefined :: e)) . toOpaque diff --git a/src/Haste/Graphics/AnimationFrame.hs b/src/Haste/Graphics/AnimationFrame.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Graphics/AnimationFrame.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-} +-- | Request and cancel animation frames from the browser. +-- Straightforward bindings to the corresponding DOM interface. +module Haste.Graphics.AnimationFrame ( + FrameRequest, HRTimeStamp, + requestAnimationFrame, + cancelAnimationFrame + ) where +import Haste.Prim.Foreign +import Haste.Performance + +-- | Handle to a previously issued request for an animation frame. +-- Only useful together with 'cancelAnimationFrame'. +newtype FrameRequest = FrameRequest JSAny deriving (ToAny, FromAny) + +-- | Request a function to be called by the browser before the next repaint. +-- Paints generally happen in tune with the user's monitor refresh rate, +-- which usually means at 60 FPS. +-- +-- Do note that you need to request *each* animation callback you plan to +-- use, similar to @setTimeout@ as opposed to @setInterval@, as they are not +-- recurring. +requestAnimationFrame :: (HRTimeStamp -> IO ()) -> IO FrameRequest +requestAnimationFrame = ffi "window.requestAnimationFrame" + +-- | Cancel an animation callback previously requested by +-- 'requestAnimationFrame'. +cancelAnimationFrame :: FrameRequest -> IO () +cancelAnimationFrame = ffi "window.cancelAnimationFrame" diff --git a/src/Haste/Graphics/Canvas.hs b/src/Haste/Graphics/Canvas.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Graphics/Canvas.hs @@ -0,0 +1,454 @@ +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, + GADTs, CPP, GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} +-- | Basic Canvas graphics library. +module Haste.Graphics.Canvas ( + -- * Basic types and classes + Bitmap, Canvas, Shape, Picture, Point, Vector, Angle, Rect (..), Color (..), + Ctx, AnyImageBuffer (..), + ImageBuffer (..), BitmapSource (..), + + -- * Obtaining a canvas + getCanvasById, getCanvas, createCanvas, + + -- * Rendering and reading canvases + render, renderOnTop, buffer, toDataURL, + + -- * Colors and opacity + setStrokeColor, setFillColor, color, opacity, + + -- * Matrix operations + translate, scale, rotate, + -- * Drawing shapes + stroke, fill, clip, + lineWidth, line, path, rect, circle, arc, + + -- * Rendering text + font, text, + + -- * Extending the library + withContext + ) where +import Control.Monad.IO.Class +import Data.Maybe (fromJust) +import Haste +import Haste.DOM.JSString +import Haste.DOM.Core +import Haste.Events.Core +import Haste.Concurrent (CIO) -- for SPECIALISE pragma +import Haste.Prim.Foreign (ToAny (..), FromAny (..), ffi) + +jsHasCtx2D :: Elem -> IO Bool +jsHasCtx2D = ffi "(function(e){return !!e.getContext;})" + +jsGetCtx2D :: Elem -> IO Ctx +jsGetCtx2D = ffi "(function(e){return e.getContext('2d');})" + +jsBeginPath :: Ctx -> IO () +jsBeginPath = ffi "(function(ctx){ctx.beginPath();})" + +jsMoveTo :: Ctx -> Double -> Double -> IO () +jsMoveTo = ffi "(function(ctx,x,y){ctx.moveTo(x,y);})" + +jsLineTo :: Ctx -> Double -> Double -> IO () +jsLineTo = ffi "(function(ctx,x,y){ctx.lineTo(x,y);})" + +jsStroke :: Ctx -> IO () +jsStroke = ffi "(function(ctx){ctx.stroke();})" + +jsFill :: Ctx -> IO () +jsFill = ffi "(function(ctx){ctx.fill();})" + +jsRotate :: Ctx -> Double -> IO () +jsRotate = ffi "(function(ctx,rad){ctx.rotate(rad);})" + +jsTranslate :: Ctx -> Double -> Double -> IO () +jsTranslate = ffi "(function(ctx,x,y){ctx.translate(x,y);})" + +jsScale :: Ctx -> Double -> Double -> IO () +jsScale = ffi "(function(ctx,x,y){ctx.scale(x,y);})" + +jsPushState :: Ctx -> IO () +jsPushState = ffi "(function(ctx){ctx.save();})" + +jsPopState :: Ctx -> IO () +jsPopState = ffi "(function(ctx){ctx.restore();})" + +jsResetCanvas :: Elem -> IO () +jsResetCanvas = ffi "(function(e){e.width = e.width;})" + +jsDrawImage :: Ctx -> Elem -> Double -> Double -> IO () +jsDrawImage = ffi "(function(ctx,i,x,y){ctx.drawImage(i,x,y);})" + +jsDrawImageClipped :: Ctx -> Elem + -> Double -> Double + -> Double -> Double -> Double -> Double + -> IO () +jsDrawImageClipped = ffi "(function(ctx, img, x, y, cx, cy, cw, ch){\ +ctx.drawImage(img, cx, cy, cw, ch, x, y, cw, ch);})" + +jsDrawImageScaled :: Ctx -> Elem + -> Double -> Double -> Double -> Double + -> IO () +jsDrawImageScaled = ffi "(function(ctx, img, x, y, w, h){\ +ctx.drawImage(img, x, y, w, h);})" + +jsDrawText :: Ctx -> JSString -> Double -> Double -> IO () +jsDrawText = ffi "(function(ctx,s,x,y){ctx.fillText(s,x,y);})" + +jsClip :: Ctx -> IO () +jsClip = ffi "(function(ctx){ctx.clip();})" + +jsArc :: Ctx -> Double -> Double + -> Double + -> Double -> Double + -> IO () +jsArc = ffi "(function(ctx, x, y, radius, fromAngle, toAngle){\ +ctx.arc(x, y, radius, fromAngle, toAngle);})" + +jsCanvasToDataURL :: Elem -> IO URL +jsCanvasToDataURL = ffi "(function(e){return e.toDataURL('image/png');})" + +-- | A bitmap, backed by an IMG element. +-- JS representation is a reference to the backing IMG element. +newtype Bitmap = Bitmap Elem + deriving (ToAny, FromAny) + +-- | Any type that contains a buffered image which can be drawn onto a canvas. +class ImageBuffer a where + -- | Draw the image buffer with its top left corner at the specified point. + draw :: a -> Point -> Picture () + -- | Draw a portion of the image buffer with its top left corner at the + -- specified point. + drawClipped :: a -> Point -> Rect -> Picture () + -- | Draw the image buffer within given rectangle. + drawScaled :: a -> Rect -> Picture () + +instance ImageBuffer Canvas where + draw (Canvas _ buf) (x, y) = Picture $ \ctx -> jsDrawImage ctx buf x y + drawClipped (Canvas _ buf) (x, y) (Rect cx cy cw ch) = Picture $ \ctx -> + jsDrawImageClipped ctx buf x y cx cy cw ch + drawScaled (Canvas _ buf) (Rect x y w h) = Picture $ \ctx -> + jsDrawImageScaled ctx buf x y w h + +instance ImageBuffer Bitmap where + draw (Bitmap buf) (x, y) = Picture $ \ctx -> jsDrawImage ctx buf x y + drawClipped (Bitmap buf) (x, y) (Rect cx cy cw ch) = Picture $ \ctx -> + jsDrawImageClipped ctx buf x y cx cy cw ch + drawScaled (Bitmap buf) (Rect x y w h) = Picture $ \ctx -> + jsDrawImageScaled ctx buf x y w h + +-- | Any type that can be used to obtain a bitmap. +class BitmapSource src where + -- | Load a bitmap from some kind of bitmap source. + loadBitmap :: MonadIO m => src -> m Bitmap + +instance BitmapSource URL where + loadBitmap url = liftIO $ do + img <- newElem "img" + setProp img "src" url + loadBitmap img + +instance BitmapSource Elem where + loadBitmap = return . Bitmap + +data AnyImageBuffer where + AnyImageBuffer :: ImageBuffer a => a -> AnyImageBuffer + +instance ImageBuffer AnyImageBuffer where + draw (AnyImageBuffer buf) = draw buf + drawClipped (AnyImageBuffer buf) = drawClipped buf + drawScaled (AnyImageBuffer buf) = drawScaled buf + +instance IsElem Canvas where + elemOf (Canvas _ctx e) = e + fromElem = getCanvas + +instance EventSource Canvas where + eventSource = eventSource . elemOf + +instance IsElem Bitmap where + elemOf (Bitmap e) = e + +-- | A point in the plane. +type Point = (Double, Double) + +-- | A two dimensional vector. +type Vector = (Double, Double) + +-- | An angle, given in radians. +type Angle = Double + +-- | A rectangle. +data Rect = Rect {rect_x :: !Double, + rect_y :: !Double, + rect_w :: !Double, + rect_h :: !Double} + +-- | A color, specified using its red, green and blue components, with an +-- optional alpha component. +data Color = RGB !Int !Int !Int + | RGBA !Int !Int !Int !Double + +-- | Somewhat efficient conversion from Color to JSString. +color2JSString :: Color -> JSString +color2JSString (RGB r g b) = + catJSStr "" ["rgb(", toJSString r, ",", toJSString g, ",", toJSString b, ")"] +color2JSString (RGBA r g b a) = + catJSStr "" ["rgba(", toJSString r, ",", + toJSString g, ",", + toJSString b, ",", + toJSString a, ")"] + +-- | A drawing context; part of a canvas. +-- JS representation is the drawing context object itself. +newtype Ctx = Ctx JSAny + deriving (ToAny, FromAny) + +-- | A canvas; a viewport into which a picture can be rendered. +-- The origin of the coordinate system used by the canvas is the top left +-- corner of the canvas element. +-- JS representation is a reference to the backing canvas element. +data Canvas = Canvas !Ctx !Elem + +instance FromAny Canvas where + fromAny c = do + mcan <- fromAny c >>= fromElem + case mcan of + Just can -> return can + _ -> error "Attempted to turn a non-canvas element into a Canvas!" + +instance ToAny Canvas where + toAny (Canvas _ el) = toAny el + +-- | A picture that can be drawn onto a canvas. +newtype Picture a = Picture {unP :: Ctx -> IO a} + +-- | A shape which can be either stroked or filled to yield a picture. +newtype Shape a = Shape {unS :: Ctx -> IO a} + +instance Functor Picture where + fmap f p = Picture $ \ctx -> + unP p ctx >>= return . f + +instance Applicative Picture where + pure a = Picture $ \_ -> return a + + pfab <*> pa = Picture $ \ctx -> do + fab <- unP pfab ctx + a <- unP pa ctx + return (fab a) + +instance Monad Picture where + return x = Picture $ \_ -> return x + Picture m >>= f = Picture $ \ctx -> do + x <- m ctx + unP (f x) ctx + +instance Functor Shape where + fmap f s = Shape $ \ctx -> + unS s ctx >>= return . f + +instance Applicative Shape where + pure a = Shape $ \_ -> return a + + sfab <*> sa = Shape $ \ctx -> do + fab <- unS sfab ctx + a <- unS sa ctx + return (fab a) + +instance Monad Shape where + return x = Shape $ \_ -> return x + Shape m >>= f = Shape $ \ctx -> do + x <- m ctx + unS (f x) ctx + +-- | Create a 2D drawing context from a DOM element identified by its ID. +getCanvasById :: MonadIO m => String -> m (Maybe Canvas) +getCanvasById eid = liftIO $ do + e <- elemById (toJSString eid) + maybe (return Nothing) getCanvas e + +{-# DEPRECATED getCanvas "use the more general fromElem instead." #-} +-- | Create a 2D drawing context from a DOM element. +getCanvas :: MonadIO m => Elem -> m (Maybe Canvas) +getCanvas e = liftIO $ do + hasCtx <- jsHasCtx2D e + case hasCtx of + True -> do + ctx <- jsGetCtx2D e + return $ Just $ Canvas ctx e + _ -> return Nothing + +-- | Create an off-screen buffer of the specified size. +createCanvas :: MonadIO m => Int -> Int -> m Canvas +createCanvas w h = liftIO $ do + buf <- newElem "canvas" + setProp buf "width" (toJSString w) + setProp buf "height" (toJSString h) + fromJust <$> getCanvas buf + +-- | Clear a canvas, then draw a picture onto it. +{-# SPECIALISE render :: Canvas -> Picture a -> IO a #-} +{-# SPECIALISE render :: Canvas -> Picture a -> CIO a #-} +render :: MonadIO m => Canvas -> Picture a -> m a +render (Canvas ctx el) (Picture p) = liftIO $ do + jsResetCanvas el + p ctx + +-- | Draw a picture onto a canvas without first clearing it. +{-# SPECIALISE renderOnTop :: Canvas -> Picture a -> IO a #-} +{-# SPECIALISE renderOnTop :: Canvas -> Picture a -> CIO a #-} +renderOnTop :: MonadIO m => Canvas -> Picture a -> m a +renderOnTop (Canvas ctx _) (Picture p) = liftIO $ p ctx + +-- | Generate a data URL from the contents of a canvas. +toDataURL :: MonadIO m => Canvas -> m URL +toDataURL (Canvas _ el) = liftIO $ jsCanvasToDataURL el + +-- | Create a new off-screen buffer and store the given picture in it. +buffer :: MonadIO m => Int -> Int -> Picture () -> m Bitmap +buffer w h pict = liftIO $ do + buf@(Canvas _ el) <- createCanvas w h + render buf pict + return $ Bitmap el + +-- | Perform a computation over the drawing context of the picture. +-- This is handy for operations which are either impossible, hard or +-- inefficient to express using the Haste.Graphics.Canvas API. +withContext :: (Ctx -> IO a) -> Picture a +withContext f = Picture $ \ctx -> f ctx + +-- | Set a new color for strokes. +setStrokeColor :: Color -> Picture () +setStrokeColor c = Picture $ \(Ctx ctx) -> do + setProp (Elem ctx) "strokeStyle" (color2JSString c) + +-- | Set a new fill color. +setFillColor :: Color -> Picture () +setFillColor c = Picture $ \(Ctx ctx) -> do + setProp (Elem ctx) "fillStyle" (color2JSString c) + +-- | Draw a picture with the given opacity. +opacity :: Double -> Picture () -> Picture () +opacity alpha (Picture pict) = Picture $ \(Ctx ctx) -> do + alpha' <- getProp (Elem ctx) "globalAlpha" + setProp (Elem ctx) "globalAlpha" (toJSString alpha) + pict (Ctx ctx) + setProp (Elem ctx) "globalAlpha" alpha' + +-- | Draw the given Picture using the specified Color for both stroke and fill, +-- then restore the previous stroke and fill colors. +color :: Color -> Picture () -> Picture () +color c (Picture pict) = Picture $ \(Ctx ctx) -> do + fc <- getProp (Elem ctx) "fillStyle" + sc <- getProp (Elem ctx) "strokeStyle" + setProp (Elem ctx) "fillStyle" c' + setProp (Elem ctx) "strokeStyle" c' + pict (Ctx ctx) + setProp (Elem ctx) "fillStyle" fc + setProp (Elem ctx) "strokeStyle" sc + where + c' = color2JSString c + +-- | Draw the given picture using a new line width. +lineWidth :: Double -> Picture () -> Picture () +lineWidth w (Picture pict) = Picture $ \(Ctx ctx) -> do + lw <- getProp (Elem ctx) "lineWidth" + setProp (Elem ctx) "lineWidth" (toJSString w) + pict (Ctx ctx) + setProp (Elem ctx) "lineWidth" lw + +-- | Draw the specified picture using the given point as the origin. +translate :: Vector -> Picture () -> Picture () +translate (x, y) (Picture pict) = Picture $ \ctx -> do + jsPushState ctx + jsTranslate ctx x y + pict ctx + jsPopState ctx + +-- | Draw the specified picture rotated @r@ radians clockwise. +rotate :: Double -> Picture () -> Picture () +rotate rad (Picture pict) = Picture $ \ctx -> do + jsPushState ctx + jsRotate ctx rad + pict ctx + jsPopState ctx + +-- | Draw the specified picture scaled as specified by the scale vector. +scale :: Vector -> Picture () -> Picture () +scale (x, y) (Picture pict) = Picture $ \ctx -> do + jsPushState ctx + jsScale ctx x y + pict ctx + jsPopState ctx + +-- | Draw a filled shape. +fill :: Shape () -> Picture () +fill (Shape shape) = Picture $ \ctx -> do + jsBeginPath ctx + shape ctx + jsFill ctx + +-- | Draw the contours of a shape. +stroke :: Shape () -> Picture () +stroke (Shape shape) = Picture $ \ctx -> do + jsBeginPath ctx + shape ctx + jsStroke ctx + +-- | Draw a picture clipped to the given path. +clip :: Shape () -> Picture () -> Picture () +clip (Shape shape) (Picture pict) = Picture $ \ctx -> do + jsPushState ctx + jsBeginPath ctx + shape ctx + jsClip ctx + pict ctx + jsPopState ctx + +-- | Draw a path along the specified points. +path :: [Point] -> Shape () +path ((x1, y1):ps) = Shape $ \ctx -> do + jsMoveTo ctx x1 y1 + mapM_ (uncurry $ jsLineTo ctx) ps +path _ = + return () + +-- | Draw a line between two points. +line :: Point -> Point -> Shape () +line p1 p2 = path [p1, p2] + +-- | Draw a rectangle between the two given points. +rect :: Point -> Point -> Shape () +rect (x1, y1) (x2, y2) = path [(x1, y1), (x2, y1), (x2, y2), (x1, y2), (x1, y1)] + +-- | Draw a circle shape. +circle :: Point -> Double -> Shape () +circle (x, y) radius = Shape $ \ctx -> do + jsMoveTo ctx (x+radius) y + jsArc ctx x y radius (0 :: Double) twoPi + +{-# INLINE twoPi #-} +twoPi :: Double +twoPi = 2*pi + +-- | Draw an arc. An arc is specified as a drawn portion of an imaginary +-- circle with a center point, a radius, a starting angle and an ending +-- angle. +-- For instance, @arc (0, 0) 10 0 pi@ will draw a half circle centered at +-- (0, 0), with a radius of 10 pixels. +arc :: Point -> Double -> Angle -> Angle -> Shape () +arc (x, y) radius from to = Shape $ \ctx -> jsArc ctx x y radius from to + +-- | Draw a picture using a certain font. Obviously only affects text. +font :: String -> Picture () -> Picture () +font f (Picture pict) = Picture $ \(Ctx ctx) -> do + f' <- getProp (Elem ctx) "font" + setProp (Elem ctx) "font" (toJSString f) + pict (Ctx ctx) + setProp (Elem ctx) "font" f' + +-- | Draw some text onto the canvas. +text :: Point -> String -> Picture () +text (x, y) str = Picture $ \ctx -> jsDrawText ctx (toJSString str) x y diff --git a/src/Haste/Hash.hs b/src/Haste/Hash.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Hash.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE FlexibleInstances, FlexibleContexts, GADTs, OverloadedStrings #-} +-- | Hash manipulation and callbacks. +module Haste.Hash ( + onHashChange, setHash, getHash + ) where +import Haste.Prim.Foreign +import Control.Monad.IO.Class +import Haste.Prim +import Haste.Events.Core + +-- | Register a callback to be run whenever the URL hash changes. +-- The first and second argument of the callback are the old and new and +-- hash respectively. +onHashChange :: MonadEvent m + => (JSString -> JSString -> m ()) + -> m () +onHashChange f = do + f' <- mkHandler $ uncurry f + firsthash <- getHash + liftIO $ jsOnHashChange firsthash f' + +jsOnHashChange :: JSString -> ((JSString, JSString) -> IO ()) -> IO () +jsOnHashChange = + ffi "(function(firsthash,cb){\ + \window.__old_hash = firsthash;\ + \window.onhashchange = function(e){\ + \var oldhash = window.__old_hash;\ + \var newhash = window.location.hash.split('#')[1] || '';\ + \window.__old_hash = newhash;\ + \cb([oldhash,newhash]);\ + \};\ + \})" + +-- | Set the hash part of the current URL. +setHash :: MonadIO m => JSString -> m () +setHash = liftIO . jsSetHash + +jsSetHash :: JSString -> IO () +jsSetHash = ffi "(function(h) {location.hash = '#'+h;})" + +-- | Read the hash part of the current URL. +getHash :: MonadIO m => m JSString +getHash = liftIO jsGetHash + +jsGetHash :: IO JSString +jsGetHash = ffi "(function() {return location.hash.substring(1);})" diff --git a/src/Haste/JSON.hs b/src/Haste/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Haste/JSON.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +-- | Haste-specific JSON library. JSON is common enough that it's a good idea +-- to create as fast and small an implementation as possible. To that end, +-- the parser is implemented entirely in Javascript, and works with any +-- browser that supports JSON.parse; IE does this from version 8 and up, and +-- everyone else has done it since just about forever. +module Haste.JSON (JSON (..), encodeJSON, decodeJSON, toObject, (!), (~>)) where +import Prelude hiding (null) +import Haste +import Haste.Prim +import Data.String as S +#ifndef __HASTE__ +import Haste.Parsing +import Numeric +#endif +import Haste.Prim.Foreign hiding (toObject) + +-- | Create a JavaScript object from a JSON object. Only makes sense in a +-- browser context, obviously. +toObject :: JSON -> JSAny +toObject = jsJSONParse . encodeJSON +jsJSONParse :: JSString -> JSAny +jsJSONParse = veryUnsafePerformIO . _jsJSONParse + +_jsJSONParse :: JSString -> IO JSAny +_jsJSONParse = ffi "JSON.parse" + +-- Remember to update jsParseJSON if this data type changes! +data JSON + = Num {-# UNPACK #-} !Double + | Str !JSString + | Bool !Bool + | Arr ![JSON] + | Dict ![(JSString, JSON)] + | Null + +instance IsString JSON where + fromString = Str . S.fromString + +instance JSType JSON where + toJSString = encodeJSON + fromJSString x = + case decodeJSON x of + Right x' -> Just x' + _ -> Nothing + +numFail :: a +numFail = error "Num JSON: not a numeric JSON node!" + +-- | This instance may be a bad idea, but it's nice to be able to create JSON +-- objects using plain numeric literals. +instance Num JSON where + (Num a) + (Num b) = Num (a+b) + _ + _ = numFail + (Num a) * (Num b) = Num (a*b) + _ * _ = numFail + (Num a) - (Num b) = Num (a-b) + _ - _ = numFail + negate (Num a) = Num (negate a) + negate _ = numFail + abs (Num a) = Num (abs a) + abs _ = numFail + signum (Num a) = Num (signum a) + signum _ = numFail + fromInteger n = Num (fromInteger n) + +#ifdef __HASTE__ +foreign import ccall "jsShow" jsShowD :: Double -> JSString +foreign import ccall "jsParseJSON" jsParseJSON :: JSString -> Ptr (Maybe JSON) +jsStringify :: JSString -> IO JSString +jsStringify = ffi "JSON.stringify" +#else +jsShowD :: Double -> JSString +jsShowD = toJSStr . flip (showFFloat Nothing) "" + +jsStringify :: JSString -> IO JSString +jsStringify = return . toJSStr . ('"' :) . unq . fromJSStr + where + unq ('"' : cs) = "\\\"" ++ unq cs + unq (c : cs) + | c == '\\' = "\\\\" ++ unq cs + | otherwise = c : unq cs + unq _ = ['"'] +#endif + +-- | Look up a JSON object from a JSON dictionary. Panics if the dictionary +-- isn't a dictionary, or if it doesn't contain the given key. +(!) :: JSON -> JSString -> JSON +dict ! k = + case dict ~> k of + Just x -> x + _ -> error $ "Haste.JSON.!: unable to look up key " ++ fromJSStr k +infixl 5 ! + +class JSONLookup a where + -- | Look up a key in a JSON dictionary. Return Nothing if the key can't be + -- found for some reason. + (~>) :: a -> JSString -> Maybe JSON +infixl 5 ~> + +instance JSONLookup JSON where + (Dict m) ~> key = lookup key m + _ ~> _ = Nothing + +instance JSONLookup (Maybe JSON) where + (Just (Dict m)) ~> key = lookup key m + _ ~> _ = Nothing + +encodeJSON :: JSON -> JSString +encodeJSON = catJSStr "" . enc [] + where + comma = "," + openbr = "[" + closebr = "]" + opencu = "{" + closecu = "}" + colon = ":" + quote = "\"" + true = "true" + false = "false" + null = "null" + enc acc Null = null : acc + enc acc (Str s) = veryUnsafePerformIO (jsStringify s) : acc + enc acc (Num d) = jsShowD d : acc + enc acc (Bool True) = true : acc + enc acc (Bool False) = false : acc + enc acc (Arr elems) + | (x:xs) <- elems = + openbr : enc (foldr (\s a -> comma:enc a s) (closebr:acc) xs) x + | otherwise = + openbr : closebr : acc + enc acc (Dict elems) + | ((key,val):xs) <- elems = + let encElem (k, v) a = comma : quote : k : quote : colon : enc a v + encAll = + opencu : veryUnsafePerformIO (jsStringify key) : colon : encRest + encRest = enc (foldr encElem (closecu:acc) xs) val + in encAll + | otherwise = + opencu : closecu : acc + +decodeJSON :: JSString -> Either JSString JSON +#ifdef __HASTE__ +decodeJSON = liftMaybe . fromPtr . jsParseJSON + where + liftMaybe (Just x) = Right x + liftMaybe _ = Left "Invalid JSON!" +#else +decodeJSON = liftMaybe . runParser json . fromJSStr + where + liftMaybe (Just x) = Right x + liftMaybe _ = Left "Invalid JSON!" + json = oneOf [Num <$> double, + Bool <$> boolean, + Str <$> jsstring, + Arr <$> array, + Dict <$> object, + null] + jsstring = toJSStr <$> oneOf [quotedString '\'', quotedString '"'] + boolean = oneOf [string "true" >> pure True, string "false" >> pure False] + null = string "null" >> pure Null + array = do + _ <- char '[' >> possibly whitespace + elements <- commaSeparated json + _ <- possibly whitespace >> char ']' + return elements + commaSeparated p = + oneOf [do x <- p + _ <- possibly whitespace >> char ',' >> possibly whitespace + xs <- commaSeparated p + return (x:xs), + do x <- p + return [x], + do return []] + object = do + _ <- char '{' >> possibly whitespace + pairs <- commaSeparated kvPair + _ <- possibly whitespace >> char '}' + return pairs + kvPair = do + k <- jsstring + _ <- possibly whitespace >> char ':' >> possibly whitespace + v <- json + return (k, v) +#endif + +instance Show JSON where + show = fromJSStr . encodeJSON diff --git a/src/Haste/JSString.hs b/src/Haste/JSString.hs new file mode 100644 --- /dev/null +++ b/src/Haste/JSString.hs @@ -0,0 +1,372 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE OverloadedStrings, ForeignFunctionInterface, CPP, MagicHash, + GeneralizedNewtypeDeriving #-} +-- | JSString standard functions, to make them a more viable alternative to +-- the horribly inefficient standard Strings. +-- +-- Many functions have linear time complexity due to JavaScript engines not +-- implementing slicing, etc. in constant time. +-- +-- All functions are supported on both client and server, with the exception +-- of 'match', 'matches', 'regex' and 'replace', which are wrappers on top of +-- JavaScript's native regular expressions and thus only supported on the +-- client. +module Haste.JSString + ( JSString + -- * Building JSStrings + , empty, singleton, pack, cons, snoc, append, replicate + -- * Deconstructing JSStrings + , (!), unpack, head, last, tail, drop, take, init, splitAt + -- * Examining JSStrings + , null, length, any, all + -- * Modifying JSStrings + , map, reverse, intercalate, foldl', foldr, concat, concatMap + -- * Regular expressions (client-side only) + , RegEx, match, matches, regex, replace + -- * JSString I/O + , putStrLn, putStr + ) where +import qualified Data.List +import Prelude hiding (foldr, concat, concatMap, reverse, map, all, any, + length, null, splitAt, init, take, drop, tail, head, + last, replicate, putStrLn, putStr) +import qualified Prelude +import Data.String +import Haste.Prim +import Haste.Prim.Foreign +import Control.Monad.IO.Class +import System.IO.Unsafe + +#ifdef __HASTE__ +import GHC.Prim + +{-# INLINE d2c #-} +d2c :: Double -> Char +d2c d = unsafeCoerce# d + +_jss_singleton :: Char -> IO JSString +_jss_singleton = ffi "String.fromCharCode" + +_jss_cons :: Char -> JSString -> IO JSString +_jss_cons = ffi "(function(c,s){return String.fromCharCode(c)+s;})" + +_jss_snoc :: JSString -> Char -> IO JSString +_jss_snoc = ffi "(function(s,c){return s+String.fromCharCode(c);})" + +_jss_append :: JSString -> JSString -> IO JSString +_jss_append = ffi "(function(a,b){return a+b;})" + +_jss_len :: JSString -> IO Int +_jss_len = ffi "(function(s){return s.length;})" + +_jss_index :: JSString -> Int -> IO Double +_jss_index = ffi "(function(s,i){return s.charCodeAt(i);})" + +_jss_substr :: JSString -> Int -> IO JSString +_jss_substr = ffi "(function(s,x){return s.substr(x);})" + +_jss_take :: Int -> JSString -> IO JSString +_jss_take = ffi "(function(n,s){return s.substr(0,n);})" + +_jss_rev :: JSString -> IO JSString +_jss_rev = ffi "(function(s){return s.split('').reverse().join('');})" + +_jss_re_match :: JSString -> RegEx -> IO Bool +_jss_re_match = ffi "(function(s,re){return s.search(re)>=0;})" + +_jss_re_compile :: JSString -> JSString -> IO RegEx +_jss_re_compile = ffi "(function(re,fs){return new RegExp(re,fs);})" + +_jss_re_replace :: JSString -> RegEx -> JSString -> IO JSString +_jss_re_replace = ffi "(function(s,re,rep){return s.replace(re,rep);})" + +_jss_re_find :: RegEx -> JSString -> IO [JSString] +_jss_re_find = ffi "(function(re,s) {\ +var a = s.match(re);\ +return a ? a : [];})" + +{-# INLINE _jss_map #-} +_jss_map :: (Char -> Char) -> JSString -> JSString +_jss_map f s = unsafePerformIO $ cmap_js (_jss_singleton . f) s + +{-# INLINE _jss_cmap #-} +_jss_cmap :: (Char -> JSString) -> JSString -> JSString +_jss_cmap f s = unsafePerformIO $ cmap_js (return . f) s + +cmap_js :: (Char -> IO JSString) -> JSString -> IO JSString +cmap_js = ffi "(function(f,s){\ +var s2 = '';\ +for(var i in s) {\ + s2 += f(s.charCodeAt(i));\ +}\ +return s2;})" + +{-# INLINE _jss_foldl #-} +_jss_foldl :: (ToAny a, FromAny a) => (a -> Char -> a) -> a -> JSString -> a +_jss_foldl f x s = fromOpaque . unsafePerformIO $ do + foldl_js (\a c -> toOpaque $ f (fromOpaque a) c) (toOpaque x) s + +foldl_js :: (Opaque a -> Char -> Opaque a) + -> Opaque a + -> JSString + -> IO (Opaque a) +foldl_js = ffi "(function(f,x,s){\ +for(var i in s) {\ + x = f(x,s.charCodeAt(i));\ +}\ +return x;})" + +{-# INLINE _jss_foldr #-} +_jss_foldr :: (ToAny a, FromAny a) => (Char -> a -> a) -> a -> JSString -> a +_jss_foldr f x s = fromOpaque . unsafePerformIO $ do + foldr_js (\c -> toOpaque . f c . fromOpaque) (toOpaque x) s + +foldr_js :: (Char -> Opaque a -> Opaque a) + -> Opaque a + -> JSString + -> IO (Opaque a) +foldr_js = ffi "(function(f,x,s){\ +for(var i = s.length-1; i >= 0; --i) {\ + x = f(s.charCodeAt(i),x);\ +}\ +return x;})" + +#else + +{-# INLINE d2c #-} +d2c :: Char -> Char +d2c = id + +_jss_singleton :: Char -> IO JSString +_jss_singleton c = return $ toJSStr [c] + +_jss_cons :: Char -> JSString -> IO JSString +_jss_cons c s = return $ toJSStr (c : fromJSStr s) + +_jss_snoc :: JSString -> Char -> IO JSString +_jss_snoc s c = return $ toJSStr (fromJSStr s ++ [c]) + +_jss_append :: JSString -> JSString -> IO JSString +_jss_append a b = return $ catJSStr "" [a, b] + +_jss_len :: JSString -> IO Int +_jss_len s = return $ Data.List.length $ fromJSStr s + +_jss_index :: JSString -> Int -> IO Char +_jss_index s n = return $ fromJSStr s !! n + +_jss_substr :: JSString -> Int -> IO JSString +_jss_substr s n = return $ toJSStr $ Data.List.drop n $ fromJSStr s + +_jss_take :: Int -> JSString -> IO JSString +_jss_take n = return . toJSStr . Data.List.take n . fromJSStr + +_jss_map :: (Char -> Char) -> JSString -> JSString +_jss_map f = toJSStr . Data.List.map f . fromJSStr + +_jss_cmap :: (Char -> JSString) -> JSString -> JSString +_jss_cmap f = + toJSStr . Data.List.concat . Data.List.map (fromJSStr . f) . fromJSStr + +_jss_rev :: JSString -> IO JSString +_jss_rev = return . toJSStr . Data.List.reverse . fromJSStr + +_jss_foldl :: (a -> Char -> a) -> a -> JSString -> a +_jss_foldl f x = Data.List.foldl' f x . fromJSStr + +_jss_foldr :: (Char -> a -> a) -> a -> JSString -> a +_jss_foldr f x = Data.List.foldr f x . fromJSStr + +_jss_re_compile :: JSString -> JSString -> IO RegEx +_jss_re_compile _ _ = + error "Regular expressions are only supported client-side!" + +_jss_re_match :: JSString -> RegEx -> IO Bool +_jss_re_match _ _ = + error "Regular expressions are only supported client-side!" + +_jss_re_replace :: JSString -> RegEx -> JSString -> IO JSString +_jss_re_replace _ _ _ = + error "Regular expressions are only supported client-side!" + +_jss_re_find :: RegEx -> JSString -> IO [JSString] +_jss_re_find _ _ = + error "Regular expressions are only supported client-side!" + +#endif + +-- | A regular expression. May be used to match and replace JSStrings. +newtype RegEx = RegEx JSAny + deriving (ToAny, FromAny) + +instance IsString RegEx where + fromString s = unsafePerformIO $ _jss_re_compile (fromString s) "" + +-- | O(1) The empty JSString. +empty :: JSString +empty = "" + +-- | O(1) JSString consisting of a single character. +singleton :: Char -> JSString +singleton = veryUnsafePerformIO . _jss_singleton + +-- | O(n) Convert a list of Char into a JSString. +pack :: [Char] -> JSString +pack = toJSStr + +-- | O(n) Convert a JSString to a list of Char. +unpack :: JSString -> [Char] +unpack = fromJSStr + +infixr 5 `cons` +-- | O(n) Prepend a character to a JSString. +cons :: Char -> JSString -> JSString +cons c s = veryUnsafePerformIO $ _jss_cons c s + +infixl 5 `snoc` +-- | O(n) Append a character to a JSString. +snoc :: JSString -> Char -> JSString +snoc s c = veryUnsafePerformIO $ _jss_snoc s c + +-- | O(n) Append two JSStrings. +append :: JSString -> JSString -> JSString +append a b = veryUnsafePerformIO $ _jss_append a b + +-- | O(1) Extract the first element of a non-empty JSString. +head :: JSString -> Char +head s = +#ifdef __HASTE__ + case veryUnsafePerformIO $ _jss_index s 0 of + c | isNaN c -> error "Haste.JSString.head: empty JSString" + | otherwise -> d2c c -- Double/Int/Char share representation. +#else + Data.List.head $ fromJSStr s +#endif + +-- | O(1) Extract the last element of a non-empty JSString. +last :: JSString -> Char +last s = + case veryUnsafePerformIO $ _jss_len s of + 0 -> error "Haste.JSString.head: empty JSString" + n -> d2c (veryUnsafePerformIO $ _jss_index s (n-1)) + +-- | Get a single character from a JSString. +(!) :: JSString -> Int -> Char +s ! n = +#ifdef __HASTE__ + case veryUnsafePerformIO $ _jss_index s n of + c | isNaN c -> error "Haste.JSString.(!): index out of bounds" + | otherwise -> d2c c -- Double/Int/Char share representation. +#else + fromJSStr s !! n +#endif + + +-- | O(n) All elements but the first of a JSString. Returns an empty JSString +-- if the given JSString is empty. +tail :: JSString -> JSString +tail s = veryUnsafePerformIO $ _jss_substr s 1 + +-- | O(n) Drop 'n' elements from the given JSString. +drop :: Int -> JSString -> JSString +drop n s = veryUnsafePerformIO $ _jss_substr s (max 0 n) + +-- | O(n) Take 'n' elements from the given JSString. +take :: Int -> JSString -> JSString +take n s = veryUnsafePerformIO $ _jss_take n s + +-- | O(n) All elements but the last of a JSString. Returns an empty JSString +-- if the given JSString is empty. +init :: JSString -> JSString +init s = veryUnsafePerformIO $ _jss_take (veryUnsafePerformIO (_jss_len s)-1) s + +-- | O(1) Test whether a JSString is empty. +null :: JSString -> Bool +null s = veryUnsafePerformIO (_jss_len s) == 0 + +-- | O(1) Get the length of a JSString as an Int. +length :: JSString -> Int +length = veryUnsafePerformIO . _jss_len + +-- | O(n) Map a function over the given JSString. +map :: (Char -> Char) -> JSString -> JSString +map f s = _jss_map f s + +-- | O(n) reverse a JSString. +reverse :: JSString -> JSString +reverse = veryUnsafePerformIO . _jss_rev + +-- | O(n) Join a list of JSStrings, with a specified separator. Equivalent to +-- 'String.join'. +intercalate :: JSString -> [JSString] -> JSString +intercalate = catJSStr + +-- | O(n) Left fold over a JSString. +foldl' :: (ToAny a, FromAny a) => (a -> Char -> a) -> a -> JSString -> a +foldl' = _jss_foldl + +-- | O(n) Right fold over a JSString. +foldr :: (ToAny a, FromAny a) => (Char -> a -> a) -> a -> JSString -> a +foldr = _jss_foldr + +-- | O(n) Concatenate a list of JSStrings. +concat :: [JSString] -> JSString +concat = catJSStr "" + +-- | O(n) Map a function over a JSString, then concatenate the results. +-- Note that this function is actually faster than 'map' in most cases. +concatMap :: (Char -> JSString) -> JSString -> JSString +concatMap = _jss_cmap + +-- | O(n) Determines whether any character in the string satisfies the given +-- predicate. +any :: (Char -> Bool) -> JSString -> Bool +any p = Haste.JSString.foldl' (\a x -> a || p x) False + +-- | O(n) Determines whether all characters in the string satisfy the given +-- predicate. +all :: (Char -> Bool) -> JSString -> Bool +all p = Haste.JSString.foldl' (\a x -> a && p x) False + +-- | O(n) Create a JSString containing 'n' instances of a single character. +replicate :: Int -> Char -> JSString +replicate n c = Haste.JSString.pack $ Data.List.replicate n c + +-- | O(n) Equivalent to (take n xs, drop n xs). +splitAt :: Int -> JSString -> (JSString, JSString) +splitAt n s = (Haste.JSString.take n s, Haste.JSString.drop n s) + +-- | As 'Prelude.putStrLn'. +putStrLn :: MonadIO m => JSString -> m () +putStrLn = liftIO . Prelude.putStrLn . unpack + +-- | As 'Prelude.putStr'. +putStr :: MonadIO m => JSString -> m () +putStr = liftIO . Prelude.putStr . unpack + +-- | O(n) Determines whether the given JSString matches the given regular +-- expression or not. +matches :: JSString -> RegEx -> Bool +matches s re = veryUnsafePerformIO $ _jss_re_match s re + +-- | O(n) Find all strings corresponding to the given regular expression. +match :: RegEx -> JSString -> [JSString] +match re s = veryUnsafePerformIO $ _jss_re_find re s + +-- | O(n) Compile a regular expression and an (optionally empty) list of flags +-- into a 'RegEx' which can be used to match, replace, etc. on JSStrings. +-- +-- The regular expression and flags are passed verbatim to the browser's +-- RegEx constructor, meaning that the syntax is the same as when using +-- regular expressions in raw JavaScript. +regex :: JSString -- ^ Regular expression. + -> JSString -- ^ Potential flags. + -> RegEx +regex re flags = veryUnsafePerformIO $ _jss_re_compile re flags + +-- | O(n) String substitution using regular expressions. +replace :: JSString -- ^ String perform substitution on. + -> RegEx -- ^ Regular expression to match. + -> JSString -- ^ Replacement string. + -> JSString +replace s re rep = veryUnsafePerformIO $ _jss_re_replace s re rep diff --git a/src/Haste/LocalStorage.hs b/src/Haste/LocalStorage.hs new file mode 100644 --- /dev/null +++ b/src/Haste/LocalStorage.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Basic bindings to HTML5 WebStorage. +module Haste.LocalStorage (setItem, getItem, removeItem) where +import Haste +import Haste.Prim.Foreign +import Haste.Serialize +import Haste.JSON + +-- | Locally store a serializable value. +setItem :: Serialize a => JSString -> a -> IO () +setItem k = store k . encodeJSON . toJSON + +store :: JSString -> JSString -> IO () +store = ffi "(function(k,v) {localStorage.setItem(k,v);})" + +-- | Load a serializable value from local storage. Will fail if the given key +-- does not exist or if the value stored at the key does not match the +-- requested type. +getItem :: Serialize a => JSString -> IO (Either JSString a) +getItem k = do + maybe (Left "No such value") (\s -> decodeJSON s >>= fromJSON) <$> load k + +load :: JSString -> IO (Maybe JSString) +load = ffi "(function(k) {return localStorage.getItem(k);})" + +-- | Remove a value from local storage. +removeItem :: JSString -> IO () +removeItem = ffi "(function(k) {localStorage.removeItem(k);})" diff --git a/src/Haste/Parsing.hs b/src/Haste/Parsing.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Parsing.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE FlexibleInstances #-} +-- | Home-grown parser, just because. +module Haste.Parsing ( + Parse, runParser, char, charP, string, oneOf, possibly, atLeast, + whitespace, word, Haste.Parsing.words, int, double, positiveDouble, + suchThat, quotedString, skip, rest, lookahead, anyChar + ) where +import Control.Applicative +import Control.Monad +import Data.Char + +newtype Parse a = Parse {unP :: (String -> Maybe (String, a))} + +runParser :: Parse a -> String -> Maybe a +runParser (Parse p) s = + case p s of + Just ("", x) -> Just x + _ -> Nothing + +instance Monad Parse where + return x = Parse $ \s -> Just (s, x) + Parse m >>= f = Parse $ \s -> do + (s', x) <- m s + unP (f x) s' + +instance Alternative Parse where + empty = mzero + (<|>) = mplus + +instance MonadPlus Parse where + mplus (Parse p1) (Parse p2) = Parse $ \s -> + case p1 s of + x@(Just _) -> x + _ -> p2 s + mzero = Parse $ const Nothing + +instance Functor Parse where + fmap f (Parse g) = Parse $ fmap (fmap f) . g + +instance Applicative Parse where + pure = return + (<*>) = ap + +-- | Read one character. Fails if end of stream. +anyChar :: Parse Char +anyChar = Parse $ \s -> + case s of + (c:cs) -> Just (cs, c) + _ -> Nothing + +-- | Require a specific character. +char :: Char -> Parse Char +char c = charP (== c) + +-- | Parse a character that matches a given predicate. +charP :: (Char -> Bool) -> Parse Char +charP p = Parse $ \s -> + case s of + (c:next) | p c -> Just (next, c) + _ -> Nothing + +-- | Require a specific string. +string :: String -> Parse String +string str = Parse $ \s -> + let len = length str + (s', next) = splitAt len s + in if s' == str + then Just (next, str) + else Nothing + +-- | Apply the first matching parser. +oneOf :: [Parse a] -> Parse a +oneOf = msum + +-- | Invoke a parser with the possibility of failure. +possibly :: Parse a -> Parse (Maybe a) +possibly p = oneOf [Just <$> p, return Nothing] + +-- | Invoke a parser at least n times. +atLeast :: Int -> Parse a -> Parse [a] +atLeast 0 p = do + x <- possibly p + case x of + Just x' -> do + xs <- atLeast 0 p + return (x':xs) + _ -> + return [] +atLeast n p = do + x <- p + xs <- atLeast (n-1) p + return (x:xs) + +-- | Parse zero or more characters of whitespace. +whitespace :: Parse String +whitespace = atLeast 0 $ charP isSpace + +-- | Parse a non-empty word. A word is a string of at least one non-whitespace +-- character. +word :: Parse String +word = atLeast 1 $ charP (not . isSpace) + +-- | Parse several words, separated by whitespace. +words :: Parse [String] +words = atLeast 0 $ word <* whitespace + +-- | Parse an Int. +int :: Parse Int +int = oneOf [read <$> atLeast 1 (charP isDigit), + char '-' >> (0-) . read <$> atLeast 1 (charP isDigit)] + +-- | Parse a floating point number. +double :: Parse Double +double = oneOf [positiveDouble, + char '-' >> (0-) <$> positiveDouble] + +-- | Parse a non-negative floating point number. +positiveDouble :: Parse Double +positiveDouble = do + first <- atLeast 1 $ charP isDigit + msecond <- possibly $ char '.' *> atLeast 1 (charP isDigit) + case msecond of + Just second -> return $ read $ first ++ "." ++ second + _ -> return $ read first + +-- | Fail on unwanted input. +suchThat :: Parse a -> (a -> Bool) -> Parse a +suchThat p f = do {x <- p ; if f x then return x else mzero} + +-- | A string quoted with the given quotation mark. Strings can contain escaped +-- quotation marks; escape characters are stripped from the returned string. +quotedString :: Char -> Parse String +quotedString q = char q *> strContents q <* char q + +strContents :: Char -> Parse String +strContents c = do + s <- atLeast 0 $ charP (\x -> x /= c && x /= '\\') + c' <- lookahead anyChar + if c == c' + then do + return s + else do + skip 1 + c'' <- anyChar + s' <- strContents c + return $ s ++ [c''] ++ s' + +-- | Read the rest of the input. +rest :: Parse String +rest = Parse $ \s -> Just ("", s) + +-- | Run a parser with the current parsing state, but don't consume any input. +lookahead :: Parse a -> Parse a +lookahead p = do + s' <- Parse $ \s -> Just (s, s) + x <- p + Parse $ \_ -> Just (s', x) + +-- | Skip n characters from the input. +skip :: Int -> Parse () +skip n = Parse $ \s -> Just (drop n s, ()) diff --git a/src/Haste/Performance.hs b/src/Haste/Performance.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Performance.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | (Very incomplete) Haste bindings to the @Performance@ DOM interface. +module Haste.Performance (HRTimeStamp, now, navigationStart) where +import Haste.Prim.Foreign + +type HRTimeStamp = Double + +-- | Returns the number of milliseconds since 'navigationStart', with +-- (theoretically) microsecond precision. +now :: IO HRTimeStamp +now = ffi "(function(){return performance.now();})" + +-- | Returns the number of milliseconds elapsed since UNIX epoch at the moment +-- when this document started loading. +navigationStart :: IO Double +navigationStart = ffi "(function(){return performance.timing.navigationStart;})" diff --git a/src/Haste/Serialize.hs b/src/Haste/Serialize.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Serialize.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-} +-- | JSON serialization and de-serialization for Haste. +module Haste.Serialize ( + Serialize (..), Parser, fromJSON, (.:), (.:?) + ) where +import GHC.Float +import GHC.Int +import Haste.JSON +import Haste.JSString (JSString) +import qualified Haste.JSString as JS +import Control.Monad (ap, when) + +class Serialize a where + toJSON :: a -> JSON + + listToJSON :: [a] -> JSON + listToJSON = Arr . map toJSON + + parseJSON :: JSON -> Parser a + + parseJSONList :: JSON -> Parser [a] + parseJSONList (Arr xs) = mapM parseJSON xs + parseJSONList _ = fail "Tried to deserialie a non-array to a list!" + +instance Serialize JSON where + toJSON = id + parseJSON = return + +instance Serialize Float where + toJSON = Num . float2Double + parseJSON (Num x) = return (double2Float x) + parseJSON _ = fail "Tried to deserialize a non-Number to a Float" + +instance Serialize Double where + toJSON = Num + parseJSON (Num x) = return x + parseJSON _ = fail "Tried to deserialize a non-Number to a Double" + +instance Serialize Int where + toJSON = Num . fromIntegral + parseJSON (Num x) = + case truncate x of + x' | fromIntegral x' == x -> + return x' + _ -> + fail "The given Number can't be represented as an Int" + parseJSON _ = + fail "Tried to deserialize a non-Number to an Int" + +instance Serialize Int8 where + toJSON = Num . fromIntegral + parseJSON (Num x) = + case truncate x of + x' | x <= 0xff && fromIntegral x' == x -> + return x' + _ -> + fail "The given Number can't be represented as an Int8" + parseJSON _ = + fail "Tried to deserialize a non-Number to an Int8" + +instance Serialize Int16 where + toJSON = Num . fromIntegral + parseJSON (Num x) = + case truncate x of + x' | x <= 0xffff && fromIntegral x' == x -> + return x' + _ -> + fail "The given Number can't be represented as an Int16" + parseJSON _ = + fail "Tried to deserialize a non-Number to an Int16" + +instance Serialize Int32 where + toJSON = Num . fromIntegral + parseJSON (Num x) = + case truncate x of + x' | x < 0xffffffff && fromIntegral x' == x -> + return x' + _ -> + fail "The given Number can't be represented as an Int32" + parseJSON _ = + fail "Tried to deserialize a non-Number to an Int32" + +instance Serialize Bool where + toJSON = Bool + parseJSON (Bool x) = return x + parseJSON _ = fail "Tried to deserialize a non-Bool to a Bool" + +instance Serialize () where + toJSON _ = Dict [] + parseJSON _ = return () + +instance Serialize Char where + toJSON c = Str $ JS.pack [c] + parseJSON (Str s) = do + when (JS.length s > 1) $ fail "Tried to deserialize long string to a Char" + return $ JS.head s + parseJSON _ = + fail "Tried to deserialize a non-string to a Char" + listToJSON = toJSON . JS.pack + parseJSONList s = fmap JS.unpack (parseJSON s) + +instance Serialize JSString where + toJSON = Str + parseJSON (Str s) = return s + parseJSON _ = fail "Tried to deserialize a non-JSString to a JSString" + +instance (Serialize a, Serialize b) => Serialize (a, b) where + toJSON (a, b) = Arr [toJSON a, toJSON b] + parseJSON (Arr [a, b]) = do + a' <- parseJSON a + b' <- parseJSON b + return (a', b') + parseJSON _ = + fail "Tried to deserialize a non-array into a pair!" + +instance Serialize a => Serialize (Maybe a) where + toJSON (Just x) = Dict [("hasValue", toJSON True), ("value", toJSON x)] + toJSON (Nothing) = Dict [("hasValue", toJSON False)] + parseJSON d = do + hasVal <- d .: "hasValue" + case hasVal of + False -> return Nothing + _ -> Just `fmap` (d .: "value") + +instance Serialize a => Serialize [a] where + toJSON = listToJSON + parseJSON = parseJSONList + +instance (Serialize a, Serialize b) => Serialize (Either a b) where + toJSON (Right x) = Dict [("success", toJSON True), ("value", toJSON x)] + toJSON (Left e) = Dict [("success", toJSON False), ("error", toJSON e)] + parseJSON d = do + success <- d .: "success" + case success of + False -> Left `fmap` (d .: "error") + _ -> Right `fmap` (d .: "value") + +fromJSON :: Serialize a => JSON -> Either JSString a +fromJSON = runParser parseJSON + +-- | Type for JSON parser. +newtype Parser a = Parser (Either JSString a) + +runParser :: (a -> Parser b) -> a -> Either JSString b +runParser p x = case p x of Parser y -> y + +instance Monad Parser where + return = Parser . return + (Parser (Right x)) >>= f = f x + (Parser (Left e)) >>= _ = Parser (Left e) + fail = Parser . Left . JS.pack + +instance Functor Parser where + fmap f m = m >>= return . f + +instance Applicative Parser where + (<*>) = ap + pure = return + +-- | Look up a key in a JSON object. +(.:) :: Serialize a => JSON -> JSString -> Parser a +Dict o .: key = + case lookup key o of + Just x -> parseJSON x + _ -> Parser . Left $ JS.concat ["Key not found: ", key] +_ .: _ = + Parser $ Left "Tried to do lookup on non-object!" + +(.:?) :: Serialize a => JSON -> JSString -> Parser (Maybe a) +o .:? key = + case o .: key of + Parser (Right x) -> return (Just x) + _ -> return Nothing diff --git a/src/Haste/Timer.hs b/src/Haste/Timer.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Timer.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings, CPP #-} +module Haste.Timer (Timer, Interval (..), setTimer, stopTimer) where +import Control.Monad.IO.Class +import Haste.Prim.Foreign +import Haste.Events.Core + +type Identifier = Int + +-- | Timer handle. +data Timer = Timer !Identifier !Interval + +-- | Interval and repeat for timers. +data Interval + = Once !Int -- ^ Fire once, in n milliseconds. + | Repeat !Int -- ^ Fire every n milliseconds. + +-- | Set a timer. +setTimer :: MonadEvent m + => Interval -- ^ Milliseconds until timer fires. + -> m () -- ^ Function to call when timer fires. + -> m Timer -- ^ Timer handle for interacting with the timer. +setTimer i f = do + f' <- mkHandler $ const f + liftIO $ do + flip Timer i <$> case i of + Once n -> timeout n (f' ()) + Repeat n -> interval n (f' ()) + +timeout :: Int -> IO () -> IO Int +timeout = ffi "(function(t,f){return window.setTimeout(f,t);})" + +interval :: Int -> IO () -> IO Int +interval = ffi "(function(t,f){return window.setInterval(f,t);})" + +-- | Stop a timer. +stopTimer :: MonadIO m => Timer -> m () +stopTimer (Timer ident (Once _)) = liftIO $ clearTimeout ident +stopTimer (Timer ident (Repeat _)) = liftIO $ clearInterval ident + +clearTimeout :: Int -> IO () +clearTimeout = ffi "(function(id){window.clearTimeout(id);})" + +clearInterval :: Int -> IO () +clearInterval = ffi "(function(id){window.clearInterval(id);})" diff --git a/src/Haste/WebSockets.hs b/src/Haste/WebSockets.hs new file mode 100644 --- /dev/null +++ b/src/Haste/WebSockets.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, FlexibleInstances #-} +-- | WebSockets API for Haste. +module Haste.WebSockets + ( module Haste.Concurrent + , WebSocket, WebSocketConfig (..), WebSocketCloseEvent (..) + , WebSocketData (..) + , noHandlers + , wsOpenSync + , wsClose + , withWebSocket, withBinaryWebSocket, wsSendBlob + ) where +import Haste +import Haste.Prim.Foreign +import Haste.Concurrent +import Haste.Binary (Blob) + +-- | A WebSocket, parameterized over the type of data that can be sent and +-- received over it. +newtype WebSocket a = WebSocket JSAny deriving (ToAny, FromAny) + +instance Eq (WebSocket a) where + (WebSocket a) == (WebSocket b) = a == b + +-- | Some data that can be sent and received over a WebSocket. +class WebSocketData a where + -- | Send a piece of data to a WebSocket of the appropriate type. + -- Returns @False@ if the data could not be sent, for instance due to a + -- closed socket. + wsSend :: WebSocket a -> a -> CIO Bool + + -- | Open a new WebSocket connection, returning @Just socket@ when successful. + wsOpen :: WebSocketConfig a -> CIO (Maybe (WebSocket a)) + +instance WebSocketData Blob where + wsSend ws b = liftIO $ sendB ws b + wsOpen = open newBin + +instance WebSocketData JSString where + wsSend ws s = liftIO $ sendS ws s + wsOpen = open new + +open mkNew (WebSocketConfig url close msg) = do + sock <- newEmptyMVar + liftIO $ mkNew url + (\s d -> concurrent $ msg s d) + (concurrent . putMVar sock . Just) + (concurrent . close) + (concurrent $ putMVar sock Nothing) + takeMVar sock + +-- | The various event handlers supported by WebSockets. +data WebSocketConfig t = WebSocketConfig + { -- | URL to which to attempt a WebSocket connection. + wsOpenURL :: URL + -- | Called when the connection is closed by the server. + , wsOnClose :: WebSocketCloseEvent -> CIO () + -- | Called when a new message arrives. + , wsOnMessage :: WebSocket t -> t -> CIO () + } + +-- | Event describing the remote closing of a WebSocket. +data WebSocketCloseEvent = WebSocketCloseEvent + { -- | Reason for close event, computer-readable version. + wsCloseCode :: Int + -- | Reason for close event, human-readable version. + , wsCloseReason :: JSString + -- | Was the socket closed cleanly? + , wsCloseClean :: Bool + } + +instance FromAny WebSocketCloseEvent where + fromAny o = WebSocketCloseEvent <$> get o "code" + <*> get o "reason" + <*> get o "wasClean" + +-- | No-op handlers for all WebSocket events. +noHandlers :: WebSocketConfig t +noHandlers = WebSocketConfig + { wsOpenURL = "" + , wsOnClose = \_ -> return () + , wsOnMessage = \_ _ -> return () + } + +-- | Open a WebSocket, returning the socket as well as a blocking CIO +-- computation to await incoming data on the socket. +-- When data arrives on the socket, the waiting computation will return +-- @Right received_data@. When the socket is closed, the waiting computation +-- will return @Left close_event@. +wsOpenSync :: WebSocketData t + => URL + -> CIO (Maybe (WebSocket t, CIO (Either WebSocketCloseEvent t))) +wsOpenSync url = do + incoming <- newEmptyMVar + msock <- wsOpen (WebSocketConfig + { wsOpenURL = url + , wsOnClose = putMVar incoming . Left + , wsOnMessage = \_ -> putMVar incoming . Right + }) + case msock of + Just sock -> return $ Just (sock, takeMVar incoming) + _ -> return Nothing + +-- | Close a WebSocket. Closing a WebSocket which has been previously closed +-- is a no-op. Any associated 'wsOnClose' handler will not be called. +wsClose :: WebSocket a -> CIO () +wsClose ws = liftIO $ close ws + + + +-- * Legacy API + +-- | Run a computation with a WebSocket. The computation will not be executed +-- until a connection to the server has been established. +-- The WebSocket will not be closed after the computation finishes. +withWebSocket :: URL + -- ^ URL to bind the WebSocket to + -> (WebSocket JSString -> JSString -> CIO ()) + -- ^ Computation to run when new data arrives + -> CIO a + -- ^ Computation to run when an error occurs + -> (WebSocket JSString -> CIO a) + -- ^ Computation using the WebSocket + -> CIO a +withWebSocket = withWS + +-- | Run a computation with a WebSocket. The computation will not be executed +-- until a connection to the server has been established. +-- The WebSocket will not be closed after the computation finishes. +withBinaryWebSocket :: URL + -- ^ URL to bind the WebSocket to + -> (WebSocket Blob -> Blob -> CIO ()) + -- ^ Computation to run when new data arrives + -> CIO a + -- ^ Computation to run when an error occurs + -> (WebSocket Blob -> CIO a) + -- ^ Computation using the WebSocket + -> CIO a +withBinaryWebSocket = withWS + +-- | Worker for legacy API. +withWS :: WebSocketData t + => URL + -> (WebSocket t -> t -> CIO ()) + -> CIO a + -> (WebSocket t -> CIO a) + -> CIO a +withWS url cb err f = do + mws <- wsOpen (noHandlers {wsOpenURL = url, wsOnMessage = cb}) + case mws of + Just ws -> f ws + _ -> err + +-- | Send a Blob over a WebSocket. +wsSendBlob :: WebSocket Blob -> Blob -> CIO Bool +wsSendBlob = wsSend + + + +-- * Hairy internals + +-- | Open a new WebSocket in text mode. +new :: URL + -> (WebSocket JSString -> JSString -> IO ()) + -> (WebSocket JSString -> IO ()) + -> (WebSocketCloseEvent -> IO ()) + -> IO () + -> IO () +new = ffi "(function(url, cb, f, close, err) {\ + \var ws = new WebSocket(url);\ + \ws.onmessage = function(e) {cb(ws,e.data);};\ + \ws.onopen = function(e) {f(ws);};\ + \ws.onclose = function(e) {close(e.data);};\ + \ws.error = function(e) {err();};\ + \return ws;\ + \})" + +-- | Open a new WebSocket in binary mode. +newBin :: URL + -> (WebSocket Blob -> Blob -> IO ()) + -> (WebSocket Blob -> IO ()) + -> (WebSocketCloseEvent -> IO ()) + -> IO () + -> IO () +newBin = ffi "(function(url, cb, f, close, err) {\ + \var ws = new WebSocket(url);\ + \ws.binaryType = 'blob';\ + \ws.onmessage = function(e) {cb(ws,e.data);};\ + \ws.onopen = function(e) {f(ws);};\ + \ws.onclose = function(e) {close(e.data);};\ + \ws.onerror = function(e) {err();};\ + \return ws;\ + \})" + +-- | Send text over a WebSocket. +sendS :: WebSocket JSString -> JSString -> IO Bool +sendS = ffi "(function(s, msg) {if(s.readyState != 1) {return false;} else {s.send(msg); return true;}})" + +-- | Send a blob over a WebSocket. +sendB :: WebSocket Blob -> Blob -> IO Bool +sendB = ffi "(function(s, msg) {if(s.readyState != 1) {return false;} else {s.send(msg); return true;}})" + +-- | Close a WebSocket. +close :: WebSocket a -> IO () +close = ffi "(function(ws){ws.onclose = ws.onerror = function(){}; ws.close();})"