myxine-client (empty) → 0.0.0.1
raw patch · 14 files changed
+1794/−0 lines, 14 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, dependent-map, dependent-sum, file-embed, hashable, http-client, http-types, myxine-client, req, template-haskell, text, transformers, unordered-containers
Files
- CHANGELOG.md +0/−0
- LICENSE +21/−0
- Setup.hs +2/−0
- enabled-events.json +349/−0
- myxine-client.cabal +90/−0
- src/Myxine.hs +58/−0
- src/Myxine/Direct.hs +347/−0
- src/Myxine/Event.hs +12/−0
- src/Myxine/Handlers.hs +77/−0
- src/Myxine/Internal/EventStream.hs +95/−0
- src/Myxine/Internal/TH.hs +337/−0
- src/Myxine/Page.hs +369/−0
- src/Myxine/Target.hs +33/−0
- test/Test.hs +4/−0
+ CHANGELOG.md view
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2019 Galois, Inc.++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ enabled-events.json view
@@ -0,0 +1,349 @@+{+ "events": {+ "blur": {+ "bubbles": false,+ "interface": "FocusEvent",+ "nameWords": [+ "blur"+ ]+ },+ "change": {+ "bubbles": true,+ "interface": "Event",+ "nameWords": [+ "change"+ ]+ },+ "click": {+ "bubbles": true,+ "interface": "MouseEvent",+ "nameWords": [+ "click"+ ]+ },+ "contextmenu": {+ "bubbles": true,+ "interface": "MouseEvent",+ "nameWords": [+ "context",+ "menu"+ ]+ },+ "dblclick": {+ "bubbles": true,+ "interface": "MouseEvent",+ "nameWords": [+ "dbl",+ "click"+ ]+ },+ "dragend": {+ "bubbles": true,+ "interface": "DragEvent",+ "nameWords": [+ "drag",+ "end"+ ]+ },+ "dragenter": {+ "bubbles": true,+ "interface": "DragEvent",+ "nameWords": [+ "drag",+ "enter"+ ]+ },+ "dragleave": {+ "bubbles": true,+ "interface": "DragEvent",+ "nameWords": [+ "drag",+ "leave"+ ]+ },+ "dragstart": {+ "bubbles": true,+ "interface": "DragEvent",+ "nameWords": [+ "drag",+ "start"+ ]+ },+ "drop": {+ "bubbles": true,+ "interface": "DragEvent",+ "nameWords": [+ "drop"+ ]+ },+ "focus": {+ "bubbles": false,+ "interface": "FocusEvent",+ "nameWords": [+ "focus"+ ]+ },+ "focusin": {+ "bubbles": true,+ "interface": "FocusEvent",+ "nameWords": [+ "focus",+ "in"+ ]+ },+ "focusout": {+ "bubbles": true,+ "interface": "FocusEvent",+ "nameWords": [+ "focus",+ "out"+ ]+ },+ "fullscreenchange": {+ "bubbles": true,+ "interface": "Event",+ "nameWords": [+ "fullscreen",+ "change"+ ]+ },+ "fullscreenerror": {+ "bubbles": true,+ "interface": "Event",+ "nameWords": [+ "fullscreen",+ "error"+ ]+ },+ "hashchange": {+ "bubbles": true,+ "interface": "HashChangeEvent",+ "nameWords": [+ "hash",+ "change"+ ]+ },+ "input": {+ "bubbles": true,+ "interface": "InputEvent",+ "nameWords": [+ "input"+ ]+ },+ "keydown": {+ "bubbles": true,+ "interface": "KeyboardEvent",+ "nameWords": [+ "key",+ "down"+ ]+ },+ "keyup": {+ "bubbles": true,+ "interface": "KeyboardEvent",+ "nameWords": [+ "key",+ "up"+ ]+ },+ "languagechange": {+ "bubbles": false,+ "interface": "Event",+ "nameWords": [+ "language",+ "change"+ ]+ },+ "load": {+ "bubbles": false,+ "interface": "Event",+ "nameWords": [+ "load"+ ]+ },+ "mousedown": {+ "bubbles": true,+ "interface": "MouseEvent",+ "nameWords": [+ "mouse",+ "down"+ ]+ },+ "mousemove": {+ "bubbles": true,+ "interface": "MouseEvent",+ "nameWords": [+ "mouse",+ "move"+ ]+ },+ "mouseout": {+ "bubbles": true,+ "interface": "MouseEvent",+ "nameWords": [+ "mouse",+ "out"+ ]+ },+ "mouseover": {+ "bubbles": true,+ "interface": "MouseEvent",+ "nameWords": [+ "mouse",+ "over"+ ]+ },+ "mouseup": {+ "bubbles": true,+ "interface": "MouseEvent",+ "nameWords": [+ "mouse",+ "up"+ ]+ },+ "reset": {+ "bubbles": true,+ "interface": "Event",+ "nameWords": [+ "reset"+ ]+ },+ "resize": {+ "bubbles": false,+ "interface": "UIEvent",+ "nameWords": [+ "resize"+ ]+ },+ "scroll": {+ "bubbles": true,+ "interface": "Event",+ "nameWords": [+ "scroll"+ ]+ },+ "select": {+ "bubbles": true,+ "interface": "UIEvent",+ "nameWords": [+ "select"+ ]+ },+ "selectionchange": {+ "bubbles": false,+ "interface": "Event",+ "nameWords": [+ "selection",+ "change"+ ]+ },+ "submit": {+ "bubbles": true,+ "interface": "Event",+ "nameWords": [+ "submit"+ ]+ },+ "unload": {+ "bubbles": false,+ "interface": "Event",+ "nameWords": [+ "unload"+ ]+ },+ "visibilitychange": {+ "bubbles": true,+ "interface": "Event",+ "nameWords": [+ "visibility",+ "change"+ ]+ },+ "wheel": {+ "bubbles": true,+ "interface": "WheelEvent",+ "nameWords": [+ "wheel"+ ]+ }+ },+ "interfaces": {+ "DragEvent": {+ "inherits": "MouseEvent",+ "properties": {}+ },+ "Event": {+ "inherits": null,+ "properties": {}+ },+ "FocusEvent": {+ "inherits": "UIEvent",+ "properties": {}+ },+ "HashChangeEvent": {+ "inherits": "Event",+ "properties": {+ "newURL": "String",+ "oldURL": "String"+ }+ },+ "InputEvent": {+ "inherits": "UIEvent",+ "properties": {+ "data": "Option<String>",+ "inputType": "Option<String>",+ "isComposing": "Option<bool>"+ }+ },+ "KeyboardEvent": {+ "inherits": "UIEvent",+ "properties": {+ "altKey": "bool",+ "code": "String",+ "ctrlKey": "bool",+ "isComposing": "bool",+ "key": "String",+ "metaKey": "bool",+ "repeat": "bool",+ "shiftKey": "bool"+ }+ },+ "MouseEvent": {+ "inherits": "UIEvent",+ "properties": {+ "altKey": "bool",+ "button": "i64",+ "buttons": "i64",+ "clientX": "f64",+ "clientY": "f64",+ "ctrlKey": "bool",+ "metaKey": "bool",+ "movementX": "f64",+ "movementY": "f64",+ "offsetX": "f64",+ "offsetY": "f64",+ "pageX": "f64",+ "pageY": "f64",+ "region": "Option<String>",+ "screenX": "f64",+ "screenY": "f64",+ "shiftKey": "bool"+ }+ },+ "UIEvent": {+ "inherits": "Event",+ "properties": {+ "detail": "Option<i64>"+ }+ },+ "WheelEvent": {+ "inherits": "MouseEvent",+ "properties": {+ "deltaMode": "i64",+ "deltaX": "f64",+ "deltaY": "f64",+ "deltaZ": "f64"+ }+ }+ }+}
+ myxine-client.cabal view
@@ -0,0 +1,90 @@+cabal-version: 2.4+name: myxine-client+version: 0.0.0.1+synopsis: A Haskell client for the Myxine GUI server+homepage: https://github.com/GaloisInc/myxine+bug-reports: https://github.com/GaloisInc/myxine/issues+license: MIT+license-file: LICENSE+author: Kenny Foner+maintainer: kwf@galois.com+copyright: Copyright (c) 2020 Galois, Inc.+category: GUI+stability: alpha+extra-source-files: CHANGELOG.md, enabled-events.json+description:+ [Myxine](https://github.com/GaloisInc/myxine) is a language-agnostic local+ server that lets you build interactive applications in the browser using a+ RESTful API. This package defines high-level typed Haskell bindings for using+ Myxine to quickly prototype surprisingly high-performance GUIs.+ .+ Myxine itself runs as a local server, separately from these bindings. It is+ built in [Rust](https://www.rust-lang.org/learn/get-started), and can be+ installed using the standard Rust build tool @cargo@:+ .+ > $ cargo install myxine+ .+ This Haskell package does __not__ manage the @myxine@ server process; it+ assumes that it is already running in the background (either started by an+ end-user, or managed by your own Haskell application).+ .+ __Required extensions:__ This library relies on the @OverloadedRecordFields@+ language extension, since a variety of browser event interfaces share field+ names/types. Without enabling it, you'll see many bewildering errors about+ ambiguous names. You may also find useful for concision the extensions+ @NamedFieldPuns@ and @RecordWildCards@.+ .+ __Package versioning and stability:__ This package should be considered in+ "alpha" stability at present. No compatibility between alpha versions is+ guaranteed.++common options+ default-language: Haskell2010+ ghc-options: -Wall+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Wcompat+ -Widentities+ -Wredundant-constraints+ -fhide-source-paths+ -Wpartial-fields++common deps+ build-depends: base ^>=4.13.0.0,+ req ^>= 3.1,+ aeson ^>= 1.4,+ text ^>= 1.2,+ transformers ^>= 0.5,+ bytestring ^>= 0.10,+ unordered-containers ^>= 0.2,+ dependent-map ^>= 0.3,+ dependent-sum ^>= 0.6,+ template-haskell ^>= 2.15,+ hashable ^>= 1.3,+ file-embed ^>= 0.0.11.1,+ http-client ^>= 0.6,+ http-types ^>= 0.12++library+ import: deps, options+ exposed-modules: Myxine+ Myxine.Direct+ other-modules: Myxine.Page+ Myxine.Target+ Myxine.Handlers+ Myxine.Event+ Myxine.Internal.EventStream+ Myxine.Internal.TH+ Paths_myxine_client+ autogen-modules: Paths_myxine_client+ hs-source-dirs: src++test-suite myxine-client-test+ import: options+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Test.hs+ build-depends: base ^>=4.13.0.0,+ myxine-client,+ text,+ bytestring
+ src/Myxine.hs view
@@ -0,0 +1,58 @@+{-# language GADTs, DataKinds, DuplicateRecordFields, RankNTypes, StrictData,+ ScopedTypeVariables, BlockArguments, KindSignatures, TemplateHaskell,+ OverloadedStrings, DerivingStrategies, DerivingVia, StandaloneDeriving,+ DeriveGeneric, DeriveAnyClass, GeneralizedNewtypeDeriving, NamedFieldPuns #-}+{-|+ Description : High-level "model-view-controller" interface to the Myxine server++ This library implements well-typed bindings to the+ [Myxine](https://github.com/GaloisInc/myxine) server for creating local+ interactive GUIs in the web browser. For more details on Myxine-the-program, see+ the package description of this library, or [its own+ homepage](https://github.com/GaloisInc/myxine).++ This module defines a higher level "model-view-controller" style interface in+ which abstracts over the direct calls to the Myxine server to allow a more+ declarative style of programming.++ For a one-to-one set of bindings directly to the corresponding calls to the+ Myxine API see the module "Myxine.Direct". This is straightforward for small+ examples and tests, but can become cumbersome for building full interactive+ applications.++ __Required extensions:__ This library relies on the @OverloadedRecordFields@+ language extension, since a variety of browser event interfaces share field+ names/types. Without enabling it, you'll see many bewildering errors about+ ambiguous names. You may also find useful for concision the extensions+ @NamedFieldPuns@ and @RecordWildCards@.+-}+module Myxine+ ( module Myxine.Page++ -- * #Types# Types and Properties of Events++-- | These types are automatically generated from Myxine's master specification+-- of supported events and interfaces, so they will always match those+-- supported by the version of Myxine corresponding to the version of this+-- library. However, Template Haskell does not allow programmatic generation+-- of Haddock documentation, so we can't put proper inline documentation+-- below.+--+-- To aid in your reference, note that the name of each type below exactly+-- matches the browser's name for events of that interface, and the names of+-- each interface's properties exactly match the browser's names for them,+-- except in the cases where those names are reserved keywords in Haskell. In+-- those cases, we prepend the name of the interface (for instance, we use the+-- property name @inputData@ instead of @data@).+--+-- For more details on the meaning of each type below and its fields, refer to+-- Myxine's documentation and/or the [MDN web API documentation for events and+-- their interfaces](https://developer.mozilla.org/docs/Web/Events).+ , module Event+ ) where++import Myxine.Event+import Myxine.Direct+import Myxine.Page+import qualified Myxine.Event as Event+ hiding (decodeSomeEventType, decodeEventProperties, encodeEventType)
+ src/Myxine/Direct.hs view
@@ -0,0 +1,347 @@+{-# language BlockArguments, ScopedTypeVariables, OverloadedStrings,+ NamedFieldPuns, GeneralizedNewtypeDeriving, DataKinds, DeriveAnyClass,+ RankNTypes, LambdaCase, DerivingStrategies #-}++{-|+Description : Direct one-to-one typed bindings to the Myxine server API++Usually, it makes the most sense to run a Myxine application using the+'Myxine.Page.Page' abstraction in the main module. However, this reactive+model-view-controller approach may not be appropriate for all needs. The+functions below are a one-to-one mapping to the API of the Myxine server.++Like the Myxine server API itself, this interface has a small surface area. You+can send a new page 'Update' using 'sendUpdate', you can loop over all page+events using 'withEvents', and you can evaluate raw JavaScript using+'evaluateJs'.+-}+module Myxine.Direct+ ( -- * Page locations on @localhost@+ PageLocation, pagePort, PagePort, pagePath, PagePath+ -- * Sending updates to pages+ , Update(..), PageContent, pageBody, pageTitle, sendUpdate+ -- * Looping over typed events+ , withEvents+ -- * Evaluating raw JavaScript in the context of a page+ , JavaScript(..), evaluateJs+ -- * Exceptions+ , EventParseException(..)+ , -- * The @Some@ existential+ ) where++import Data.Maybe+import Data.Monoid+import Data.String+import Control.Monad+import Control.Concurrent+import Data.List+import Control.Exception+import Data.Dependent.Map (Some(..))+import qualified Data.ByteString.Lazy.Char8 as ByteString+import Data.ByteString.Lazy.Char8 (ByteString)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Aeson as JSON+import qualified Network.HTTP.Req as Req+import Network.HTTP.Types (ok200)+import Network.HTTP.Client (responseStatus, responseBody)++import Myxine.Event+import Myxine.Internal.EventStream+import Myxine.Target++-- | If the response from the server fails to parse, this exception is thrown.+-- This should never happen in ordinary circumstances; if it does, your version+-- of the client library may mismatch the version of the Myxine server you are+-- running, or there may be a bug in the Myxine server or this library.+--+-- If you encounter this exception in the wild, please file a bug report at+-- <https://github.com/GaloisInc/myxine/issues/new>. Thanks!+data EventParseException+ = TargetParseException String+ -- ^ The target path failed to parse+ | UnknownEventTypeException ByteString+ -- ^ The event type failed to parse+ | EventDataParseException ByteString String ByteString+ -- ^ The properties associated with the event type failed to parse+ deriving (Eq, Ord, Exception)++instance Show EventParseException where+ show exn =+ "*** Myxine client panic: Failed to parse " <> component <> "! This means one of:\n\n"+ <> " 1) You connected to an event source that is not the Myxine server\n"+ <> " 2) You connected to a Myxine server process with an incompatible major version\n"+ <> " 3) There is a bug in the Myxine server or client library (totally possible!)\n\n"+ <> " If you suspect it's (3), please file a bug report at:\n\n " <> bugReportURL <> "\n\n"+ <> " Please include the version of this library, the version of the Myxine server,\n"+ <> " and the following details:\n\n"+ <> details+ where+ component, details, bugReportURL :: String+ (component, details) = case exn of+ TargetParseException input ->+ ("target path",+ " - Unparseable target path: " <> show input)+ UnknownEventTypeException eventType ->+ ("event type",+ " - Unknown event type: " <> show eventType)+ EventDataParseException eventType parseError badInput ->+ ("event properties",+ " - Known event type: " <> show eventType <> "\n" <>+ " - Parse error: " <> parseError <> "\n" <>+ " - Bad input properties: " <> show badInput)+ bugReportURL = "https://github.com/GaloisInc/myxine/issues/new"++-- | The view of a page, as rendered in the browser. Create page content with+-- 'pageBody' and 'pageTitle', and combine content using the 'Semigroup'+-- instance.+--+-- __Note:__ The 'Semigroup' instance for 'PageContent' takes the last specified+-- 'pageTitle' (if any), and concatenates in order each specified 'pageBody'.+data PageContent+ = PageContent+ { pageContentBody :: Text+ , pageContentTitle :: Last Text+ } deriving (Eq, Ord, Show)++instance Semigroup PageContent where+ PageContent body title <> PageContent body' title' =+ PageContent (body <> body') (title <> title')++instance Monoid PageContent where+ mempty = PageContent mempty mempty++-- | Create a rendered 'PageContent' with an empty @title@ and the specified+-- text as its @body@.+pageBody :: Text -> PageContent+pageBody body = mempty { pageContentBody = body }++-- | Create a rendered 'PageContent' with an empty @body@ and the specified+-- text as its @title@.+pageTitle :: Text -> PageContent+pageTitle title = mempty { pageContentTitle = Last (Just title) }++-- | A full page update as ready-to-send to the Myxine server.+data Update+ = Dynamic -- ^ A dynamic page which can be updated live+ PageContent+ -- ^ The content of the page (create this using 'pageBody' and/or+ -- 'pageTitle', combining using the 'Semigroup' instance)+ | Static -- ^ A static file which is hosted precisely as specified+ ByteString -- ^ The @Content-Type@ of the content+ ByteString -- ^ The raw bytes to be served by the server+ deriving (Eq, Ord, Show)++-- | Compute the localhost 'Req.Url' of a given path, allowing for dynamic+-- appearances of @/@ in the URL.+pageUrl :: PagePath -> Req.Url 'Req.Http+pageUrl (PagePath p) =+ foldl' (Req./:) (Req.http "localhost") (Text.split ('/' ==) p)++-- | A local port at which the server is expected to be running. Create one+-- using an integer literal or 'fromInteger'.+newtype PagePort+ = PagePort Int+ deriving newtype (Num, Eq, Ord, Show)++-- | A path at "localhost/..." at which to perform some action. Create one using+-- a string literal or 'Data.String.fromString'.+newtype PagePath+ = PagePath Text+ deriving newtype (IsString, Eq, Ord, Show)++-- | The options for connecting to the Myxine server. This is an opaque+-- 'Monoid': set options by combining 'pagePort' and/or 'pagePath' using their+-- 'Semigroup' instance.+data PageLocation+ = PageLocation+ { pageLocationPort :: Last PagePort+ , pageLocationPath :: Last PagePath+ } deriving (Eq, Ord, Show)++-- | Set the path to something other than the default of @/@.+pagePath :: PagePath -> PageLocation+pagePath p = mempty { pageLocationPath = Last (Just p) }++-- | Set the port to a non-default port. This is only necessary when Myxine is+-- running on a non-default port also.+pagePort :: PagePort -> PageLocation+pagePort p = mempty { pageLocationPort = Last (Just p) }++-- | The default port for the Myxine server+defaultPort :: Int+defaultPort = 1123++instance Semigroup PageLocation where+ PageLocation port1 path1 <> PageLocation port2 path2 =+ PageLocation (port1 <> port2) (path1 <> path2)++instance Monoid PageLocation where+ mempty = PageLocation+ { pageLocationPort = mempty+ , pageLocationPath = mempty }++-- | Send a full-page update to Myxine at a particular port and path. An+-- 'Update' is either a 'Dynamic' page body with an optional title, or a+-- 'Static' file with a particular Content-Type.+sendUpdate ::+ PageLocation {- ^ The location of the page to update -} ->+ Update {- ^ The new content of the page to display -} ->+ IO ()+sendUpdate PageLocation{pageLocationPort = Last maybePort,+ pageLocationPath = Last maybePath} update =+ do _ <- Req.runReq Req.defaultHttpConfig $+ Req.req Req.POST url body+ Req.ignoreResponse (portOption <> params)+ pure ()+ where+ url = pageUrl (fromMaybe "" maybePath)+ portOption = Req.port (maybe defaultPort (\(PagePort p) -> p) maybePort)++ body :: Req.ReqBodyLbs+ params :: Req.Option 'Req.Http+ (body, params) = case update of+ Dynamic (PageContent{pageContentTitle = Last maybeTitle,+ pageContentBody = text}) ->+ ( Req.ReqBodyLbs (ByteString.fromStrict (Text.encodeUtf8 text))+ , foldMap ("title" Req.=:) maybeTitle )+ Static contentType content ->+ ( Req.ReqBodyLbs content+ , Req.header "Content-Type" (ByteString.toStrict contentType)+ <> Req.queryFlag "static" )++-- | A piece of raw JavaScript to evaluate: either an expression or a block of+-- statements. Expressions need not terminate with a @return@ statement but+-- cannot span multiple lines; block need to have an explicit @return@, but can+-- contain multiple statements and lines.+data JavaScript+ = JsExpression Text -- ^ A JavaScript expression+ | JsBlock Text -- ^ A block of JavaScript statements+ deriving (Eq, Ord, Show)++-- | Evaluate some raw JavaScript in the context of a given page+--+-- Returns either a deserialized Haskell type, or a human-readable string+-- describing any error that occurred. Possible errors include:+--+-- * Any exception in the given JavaScript+-- * Absence of any browser window currently viewing the page (since there's no+-- way to evaluate JavaScript without a JavaScript engine)+-- * Evaluation timeout (default is 1000 milliseconds, but can be overridden in+-- the timeout parameter to this function+-- * Invalid JSON response for the result type inferred (use 'JSON.Value' if you+-- don't know what shape of data you're waiting to receive).+--+-- Further caveats:+--+-- * JavaScript @undefined@ is translated to @null@ in the results+-- * 'JsBlock' inputs which don't explicitly return a value result in @null@+-- * Return types are limited to those which can be serialized via+-- [@JSON.stringify@](https://developer.mozilla.org/docs/Web/JavaScript/Reference/Global_Objects/JSON/stringify),+-- which does not work for cyclic objects (like @window@, @document@, and all+-- DOM nodes), and may fail to serialize some properties for other non-scalar+-- values. If you want to return a non-scalar value like a list or dictionary,+-- construct it explicitly yourself by copying from the fields of the object+-- you're interested in.+evaluateJs ::+ JSON.FromJSON a =>+ PageLocation {- ^ The location of the page in which to evaluate the JavaScript -} ->+ Maybe Int {- ^ An optional override for the default timeout of 1000 milliseconds -} ->+ JavaScript {- ^ The JavaScript to evaluate: either a 'JsExpression' or a 'JsBlock' -} ->+ IO (Either String a)+evaluateJs PageLocation{pageLocationPort = Last maybePort,+ pageLocationPath = Last maybePath} timeout js =+ do result <- Req.runReq Req.defaultHttpConfig $+ Req.req Req.POST url body Req.lbsResponse+ (portOption <> timeoutOption <> exprOption)+ pure if Req.responseStatusCode result == 200+ then JSON.eitherDecode (Req.responseBody result)+ else Left (ByteString.unpack (Req.responseBody result))+ where+ url = pageUrl (fromMaybe "" maybePath)+ portOption = Req.port (maybe defaultPort (\(PagePort p) -> p) maybePort)++ body :: Req.ReqBodyLbs+ exprOption, timeoutOption :: Req.Option 'Req.Http+ timeoutOption = foldMap ("timeout" Req.=:) timeout+ (body, exprOption) = case js of+ JsExpression expr ->+ (Req.ReqBodyLbs "", "evaluate" Req.=: expr)+ JsBlock block ->+ (Req.ReqBodyLbs (ByteString.fromStrict (Text.encodeUtf8 block)),+ Req.queryFlag "evaluate")++-- | Given a page location and list of events, make a request to Myxine for the+-- event stream at that location and run the provided callback for each typed+-- event in the stream. If no list of events is specified (@Nothing@), every+-- event will be listened for. If the specific list of no events (@Just []@) is+-- specified, this function will sleep forever.+--+-- This blocks until the stream is closed by the server, or an exception is+-- encountered. This throws 'EventParseException' if the server sends an+-- unparseable event (this shouldn't happen in normal operation), and+-- 'Req.HttpException' if the underlying connection has an issue.+withEvents ::+ PageLocation+ {- ^ The location of the page to listen for events from -} ->+ Maybe [Some EventType]+ {- ^ The list of events for which to listen -} ->+ (forall d. EventType d -> d -> [Target] -> IO ())+ {- ^ The action to perform when each event happens -} ->+ IO ()+withEvents _ (Just []) _ =+ -- if the user requests no events, there is no corresponding Myxine API+ -- request to handle this, so we just sleep forever+ forever (threadDelay maxBound)+withEvents PageLocation{pageLocationPort = Last maybePort,+ pageLocationPath = Last maybePath} events perEvent =+ do withStreamEvents url+ (portOption <> eventParams)+ \StreamEvent{eventId, eventType, eventData} -> do+ targets <- either (throwIO . TargetParseException)+ pure (JSON.eitherDecode eventId)+ withParsedEvent eventType eventData \case+ Left Nothing -> throwIO (UnknownEventTypeException eventType)+ Left (Just err) -> throwIO (EventDataParseException eventType err eventData)+ Right (eventTy, properties) ->+ perEvent eventTy properties targets+ where+ url = pageUrl (fromMaybe "" maybePath)+ portOption = Req.port (maybe defaultPort (\(PagePort p) -> p) maybePort)++ eventParams :: Req.Option 'Req.Http+ eventParams = case events of+ Nothing -> Req.queryFlag "events"+ Just es -> flip foldMap es+ \(Some e) -> "event" Req.=: ByteString.unpack (encodeEventType e)++-- | Given an event name and properties as raw bytestrings, invoke the given+-- callback if the event parses properly, or return 'Nothing'.+withParsedEvent ::+ ByteString -> ByteString -> (forall d. Either (Maybe String) (EventType d, d) -> r) -> r+withParsedEvent name properties k =+ case decodeSomeEventType name of+ Nothing -> k (Left Nothing)+ Just (Some t) -> case decodeEventProperties t properties of+ Left err -> k (Left (Just err))+ Right p -> k (Right (t, p))++-- | Request an event-stream from the given 'Req.Url' with the given+-- 'Req.Option's, and run the provided callback for each StreamEvent. This+-- throws 'Req.HttpException' when the underlying connection has an issue.+withStreamEvents ::+ Req.Url scheme -> Req.Option scheme -> (StreamEvent -> IO ()) -> IO ()+withStreamEvents url options withEvent =+ Req.runReq Req.defaultHttpConfig $ Req.reqBr Req.GET url Req.NoReqBody options+ \response ->+ if responseStatus response /= ok200+ then pure ()+ else do+ let nextChunk = ByteString.fromStrict <$> responseBody response+ nextLine <- linesFromChunks nextChunk+ nextEvent <- eventsFromLines nextLine+ let loop = do+ maybeEvent <- nextEvent+ maybe (pure ()) (\e -> withEvent e >> loop) maybeEvent+ loop
+ src/Myxine/Event.hs view
@@ -0,0 +1,12 @@+{-# language TemplateHaskell, StrictData, DeriveGeneric, DeriveAnyClass, GADTs,+ KindSignatures, StandaloneDeriving, OverloadedStrings, EmptyCase,+ DuplicateRecordFields, DerivingStrategies #-}+{-# options_ghc -Wno-name-shadowing -Wno-unused-matches #-}+{-# options_haddock not-home #-}++module Myxine.Event where++import Data.FileEmbed+import Myxine.Internal.TH++mkEventsAndInterfaces $(embedFile "enabled-events.json")
+ src/Myxine/Handlers.hs view
@@ -0,0 +1,77 @@+module Myxine.Handlers (Handlers, on, handle, handledEvents) where++import Data.Maybe+import Data.Dependent.Map (DMap, Some)+import qualified Data.Dependent.Map as DMap++import Myxine.Event+import Myxine.Target++-- | Create a handler for a specific event type by specifying the type of event+-- and the monadic callback to be invoked when the event occurs.+--+-- The provided callback will be given the @'EventType' props@ of the event, the+-- properties @props@ of this particular event, a list of 'Target's on which the+-- event fired, in order from most to least specific, and the current @model@ of+-- a page. It has the option to do arbitrary 'IO', and to return a+-- possibly-changed @model@.+--+-- Notice that each variant of 'EventType' has a type-level index describing+-- what kind of data is carried by events of that type. This means that, for+-- instance, if you want to handle a 'Click' event, which has the type+-- 'EventType MouseEvent', your event handler as created by 'on' will be given+-- access to a 'MouseEvent' data structure when it is invoked. That is to say:+--+-- @+-- 'on' 'Click' (\properties@'MouseEvent'{} targets model ->+-- do print properties+-- print targets+-- print model)+-- :: 'Show' model => 'Handlers' model+-- @+--+-- A full listing of all available 'EventType's and their corresponding property+-- records can be found in the below section on [types and properties of+-- events](#Types).+on :: EventType props -> (props -> [Target] -> model -> IO model) -> Handlers model+on event h = Handlers (DMap.singleton event (Handler h))+{-# INLINE on #-}++-- | Dispatch all the event handler callbacks for a given event type and its+-- corresponding data. Event handlers for this event type will be called in the+-- order they were registered (left to right) with the result of the previous+-- handler fed as the input to the next one.+handle :: Handlers model -> EventType props -> props -> [Target] -> model -> IO model+handle (Handlers allHandlers) event props path model =+ let Handler handler =+ fromMaybe (Handler (const (const (const (pure model)))))+ (DMap.lookup event allHandlers)+ in handler props path model+{-# INLINE handle #-}++-- | Get a list of all the events which are handled by these handlers.+handledEvents :: Handlers model -> [Some EventType]+handledEvents (Handlers handlers) = DMap.keys handlers++-- | A set of handlers for events, possibly empty. Create new 'Handlers' using+-- 'on', and combine 'Handlers' together using their 'Monoid' instance.+newtype Handlers model+ = Handlers (DMap EventType (Handler model))++instance Semigroup (Handlers model) where+ Handlers hs <> Handlers hs' =+ Handlers (DMap.unionWithKey (const (<>)) hs hs')++instance Monoid (Handlers model) where+ mempty = Handlers mempty++-- | A handler for a single event type with associated data @props@.+newtype Handler model props+ = Handler (props -> [Target] -> model -> IO model)++instance Semigroup (Handler model props) where+ Handler h <> Handler g =+ Handler (\props p a -> h props p a >>= g props p)++instance Monoid (Handler model props) where+ mempty = Handler (\_ _ a -> pure a)
+ src/Myxine/Internal/EventStream.hs view
@@ -0,0 +1,95 @@+{-# language ScopedTypeVariables, BlockArguments, OverloadedStrings,+ FlexibleInstances, TypeApplications, ViewPatterns, LambdaCase #-}++{-| * A generic implementation of @text/event-stream@ parsing++ __Note:__ No end-user of this library needs to use this module; it's exposed+ for testing purposes and is not guaranteed to follow the PVP.+-}+module Myxine.Internal.EventStream+ ( StreamEvent(..)+ , eventsFromLines+ , linesFromChunks+ ) where++import Data.Maybe+import Data.Monoid+import Data.ByteString.Lazy.Char8 (ByteString)+import qualified Data.ByteString.Lazy.Char8 as ByteString+import qualified Data.ByteString.Lazy.Builder as ByteString+import Data.List.NonEmpty (NonEmpty(..))+import Data.IORef++data StreamEvent+ = StreamEvent+ { eventId :: ByteString+ , eventType :: ByteString+ , eventData :: ByteString+ } deriving (Eq, Ord, Show)++eventsFromLines :: IO (Maybe ByteString) -> IO (IO (Maybe StreamEvent))+eventsFromLines nextLine = do+ current <- newIORef mempty+ pure (go current)+ where+ go :: IORef (Any, Last ByteString, Last ByteString, Endo [ByteString]) -> IO (Maybe StreamEvent)+ go current = nextLine >>= maybe (pure Nothing) \line -> do+ if line == ""+ then tryYield current+ else+ let (field, rest) = ByteString.break (':' ==) line+ value = case ByteString.uncons rest of+ Just (_, rest') -> case ByteString.uncons rest' of+ Just (' ', rest'') -> rest''+ _ -> rest'+ Nothing -> rest+ event' = case field of+ "id" -> (Any True, pure value, mempty, mempty)+ "event" -> (Any True, mempty, pure value, mempty)+ "data" -> (Any True, mempty, mempty, Endo (value :))+ _ -> mempty+ in do+ event <- readIORef current+ writeIORef current (event <> event')+ go current++ tryYield :: IORef (Any, Last ByteString, Last ByteString, Endo [ByteString]) -> IO (Maybe StreamEvent)+ tryYield current = do+ event <- readIORef current+ writeIORef current mempty+ maybe (go current) (pure . Just) (finalize event)++ finalize :: (Any, Last ByteString, Last ByteString, Endo [ByteString]) -> Maybe StreamEvent+ finalize ( Any False, _, _, _ ) = Nothing+ finalize ( Any True+ , Last (fromMaybe "" -> i)+ , Last (fromMaybe "" -> t)+ , Endo (ByteString.intercalate "\n" . ($ []) -> d) ) =+ Just (StreamEvent { eventId = i, eventType = t, eventData = d })++linesFromChunks :: IO ByteString -> IO (IO (Maybe ByteString))+linesFromChunks nextChunk = do+ remainder <- newIORef (Just (Right mempty))+ pure (go remainder)+ where+ go :: IORef (Maybe (Either (NonEmpty ByteString) ByteString.Builder)) -> IO (Maybe ByteString)+ go remainder = readIORef remainder >>= \case+ (Just (Left (unfinished :| []))) -> do+ writeIORef remainder (Just (Right (ByteString.lazyByteString unfinished)))+ go remainder+ (Just (Left (complete :| next : rest))) -> do+ writeIORef remainder (Just (Left (next :| rest)))+ pure (Just complete)+ (Just (Right current)) -> do+ chunk <- nextChunk+ case ByteString.split '\n' chunk of+ [] -> do+ writeIORef remainder Nothing+ go remainder+ [unfinished] -> do+ writeIORef remainder (Just (Right (current <> ByteString.lazyByteString unfinished)))+ go remainder+ (end : next : rest) -> do+ writeIORef remainder (Just (Left (next :| rest)))+ pure (Just (ByteString.toLazyByteString (current <> ByteString.lazyByteString end)))+ Nothing -> pure Nothing
+ src/Myxine/Internal/TH.hs view
@@ -0,0 +1,337 @@+{-# language GADTs, DataKinds, DuplicateRecordFields, RankNTypes, StrictData,+ ScopedTypeVariables, BlockArguments, KindSignatures, TemplateHaskell,+ OverloadedStrings, DerivingStrategies, DerivingVia, StandaloneDeriving,+ DeriveGeneric, DeriveAnyClass, NamedFieldPuns, GeneralizedNewtypeDeriving,+ TupleSections, LambdaCase #-}+{-# options_ghc -Wno-incomplete-uni-patterns #-}++{-| * Internal Template-Haskell for generating events++ __Note:__ This module is used exclusively to template the various event and+ event interface data types used by this library. It is not intended for+ external use, and may not follow the PVP.+-}+module Myxine.Internal.TH (mkEventsAndInterfaces) where++import qualified Data.Aeson as JSON+import qualified Data.Aeson.Types as JSON+import Data.Bifunctor+import qualified Data.ByteString as ByteString.Strict+import Data.ByteString.Lazy (ByteString)+import qualified Data.Char as Char+import Data.Dependent.Map (Some(..))+import Data.Either+import Data.Foldable+import Data.GADT.Compare+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HashMap+import Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet+import qualified Data.Kind+import Data.List+import Data.Ord+import Data.Text (Text)+import Data.Traversable+import qualified GHC.Generics as Generic+import Language.Haskell.TH++eventTypeName, decodeEventPropertiesName, decodeSomeEventTypeName, encodeEventTypeName :: Name+eventTypeName = mkName "EventType"+decodeEventPropertiesName = mkName "decodeEventProperties"+decodeSomeEventTypeName = mkName "decodeSomeEventType"+encodeEventTypeName = mkName "encodeEventType"++interfaceTypes :: HashMap String (Q Type)+interfaceTypes = HashMap.fromList+ [ ("f64", [t|Double|])+ , ("i64", [t|Int|])+ , ("String", [t|Text|])+ , ("bool", [t|Bool|])+ , ("Option<f64>", [t|Maybe Double|])+ , ("Option<i64>", [t|Maybe Int|])+ , ("Option<String>", [t|Maybe Text|])+ , ("Option<bool>", [t|Maybe Bool|])+ ]++mkEventsAndInterfaces :: ByteString.Strict.ByteString -> Q [Dec]+mkEventsAndInterfaces enabledEventsByteString =+ case JSON.eitherDecodeStrict' enabledEventsByteString of+ Right EnabledEvents{events, interfaces} -> do+ interfaceDecs <- mkInterfaces interfaces+ eventDecs <- mkEvents events+ pure $ interfaceDecs <> eventDecs+ Left err -> do+ reportError err+ pure []++data EnabledEvents+ = EnabledEvents+ { events :: Events+ , interfaces :: Interfaces+ } deriving (Eq, Ord, Show, Generic.Generic, JSON.FromJSON)++newtype Events+ = Events (HashMap String EventInfo)+ deriving (Eq, Ord, Show)+ deriving newtype (JSON.FromJSON)++data EventInfo+ = EventInfo+ { interface :: String+ , nameWords :: [String]+ } deriving (Eq, Ord, Show, Generic.Generic, JSON.FromJSON)++newtype Interfaces+ = Interfaces (HashMap String Interface)+ deriving (Eq, Ord, Show, Generic.Generic)+ deriving newtype (JSON.FromJSON)++data Interface+ = Interface+ { inherits :: Maybe String+ , properties :: Properties+ } deriving (Eq, Ord, Show, Generic.Generic, JSON.FromJSON)++newtype Properties+ = Properties (HashMap String String)+ deriving (Eq, Ord, Show, Generic.Generic)+ deriving newtype (Semigroup, Monoid, JSON.FromJSON)++allInterfaceProperties :: Interfaces -> String -> Either (Either (Maybe String) [String]) Properties+allInterfaceProperties (Interfaces interfaces) = go HashSet.empty []+ where+ go :: HashSet String -> [String] -> String -> Either (Either (Maybe String) [String]) Properties+ go seen seenList name+ | HashSet.member name seen = Left (Right (name : seenList))+ | otherwise = do+ Interface{inherits, properties} <-+ maybe (Left (Left (if length seenList <= 1 then Just name else Nothing)))+ Right+ (HashMap.lookup name interfaces)+ rest <- maybe (pure mempty) (go (HashSet.insert name seen) (name : seenList)) inherits+ pure (properties <> rest)++fillInterfaceProperties :: Interfaces -> Either [(String, Either (Maybe String) [String])] Interfaces+fillInterfaceProperties i@(Interfaces interfaces) =+ if bad == []+ then (Right good)+ else (Left bad)+ where+ good :: Interfaces+ bad :: [(String, Either (Maybe String) [String])]+ (bad, good) =+ second (Interfaces . HashMap.fromList)+ . partitionEithers+ . map (\(name, maybeInterface) ->+ either (Left . (name,)) (Right . (name,)) maybeInterface)+ $ results++ results :: [(String, Either (Either (Maybe String) [String]) Interface)]+ results = map (\(name, Interface{inherits}) ->+ (name, (\properties -> Interface{inherits, properties})+ <$> allInterfaceProperties i name))+ (HashMap.toList interfaces)++mkEvents :: Events -> Q [Dec]+mkEvents (Events events) = do+ cons <- for (sortBy (comparing (interface . snd) <> comparing fst) $+ HashMap.toList events)+ \(eventName, EventInfo{interface, nameWords}) -> do+ let conName = concatMap (onFirst Char.toUpper) nameWords+ (eventName,) <$>+ gadtC [mkName conName] []+ (appT (conT eventTypeName)+ (conT (mkName interface)))+ starArrowStar <- [t|Data.Kind.Type -> Data.Kind.Type|]+ dec <- dataD (pure []) eventTypeName [] (Just starArrowStar) (pure <$> map snd cons) []+ eqInstance <- deriveEvent [t|Eq|]+ ordInstance <- deriveEvent [t|Ord|]+ showInstance <- deriveEvent [t|Show|]+ geqInstance <- mkEnumGEqInstance eventTypeName (map snd cons)+ gcompareInstance <- mkEnumGCompareInstance eventTypeName (map snd cons)+ encodeEventType <- mkEncodeEventType cons+ decodeSomeEventType <- mkDecodeSomeEventType cons+ decodeEventProperties <- mkDecodeEventProperties (map snd cons)+ pure $ decodeSomeEventType <> decodeEventProperties <> encodeEventType <>+ [ dec+ , eqInstance+ , ordInstance+ , showInstance+ , geqInstance+ , gcompareInstance+ ]+ where+ deriveEvent typeclass =+ standaloneDerivD (pure []) [t|forall d. $typeclass ($(pure (ConT eventTypeName)) d)|]++mkInterfaces :: Interfaces -> Q [Dec]+mkInterfaces interfaces =+ case fillInterfaceProperties interfaces of+ Right (Interfaces filledInterfaces) ->+ concat <$> for (reverse . sortOn fst $ HashMap.toList filledInterfaces)+ \(name, interface) ->+ mkInterface name interface+ Left wrong -> do+ for_ wrong \(interface, err) ->+ case err of+ Left Nothing -> pure ()+ Left (Just directUnknown) ->+ reportError $ "Unknown interface \"" <> directUnknown+ <> "\" inherited by \"" <> interface <> "\""+ Right cyclic ->+ reportError $ "Cycle in interface inheritance: "+ <> intercalate " <: " (reverse cyclic)+ pure []++mkInterface :: String -> Interface -> Q [Dec]+mkInterface interfaceName Interface{properties = Properties properties} =+ let propertyList = HashMap.toList properties+ badFields =+ filter (not . (flip HashMap.member interfaceTypes) . snd) propertyList+ in if badFields == []+ then do+ fields <- sequence+ [ (propName, Bang NoSourceUnpackedness SourceStrict,)+ <$> interfaceTypes HashMap.! propType+ | (propName, propType) <- propertyList ]+ dec <- dataD (pure []) (mkName interfaceName) [] Nothing+ [recC (mkName interfaceName) $+ pure . (\(n,s,t) -> (mkName (avoidKeywordProp interfaceName n), s, t)) <$> sort fields]+ [derivClause Nothing [[t|Eq|], [t|Ord|], [t|Show|]]]+ -- This "manually" derived FromJSON instance is necessary because Aeson+ -- doesn't guarantee stability of encoding. In particular, unit-like things+ -- are currently serialized as [] and not {}, even if they are record-like.+ preludeMaybe <- [t|Maybe|]+ o <- newName "o"+ fromJSON <-+ [d| instance JSON.FromJSON $(conT (mkName interfaceName)) where+ parseJSON (JSON.Object $(varP o)) =+ $(doE $ [ let name' = avoidKeywordProp interfaceName name+ get = case ty of+ -- This lets Maybe fields really be optional+ AppT c _ | c == preludeMaybe -> [|(JSON..:?)|]+ _ -> [|(JSON..:)|]+ in bindS (varP (mkName name')) [|$get $(varE o) $(litE (stringL name))|]+ | (name, _, ty) <- fields ]+ <> [ noBindS [|pure $(recConE (mkName interfaceName)+ [ let name' = avoidKeywordProp interfaceName name+ in pure (mkName name', VarE (mkName name'))+ | (name, _, _) <- fields ]) |] ])+ parseJSON invalid =+ JSON.prependFailure $(litE (stringL ("parsing " <> interfaceName <> " failed, ")))+ (JSON.typeMismatch "Object" invalid)+ |]+ pure $ [dec] <> fromJSON+ else do+ for_ badFields \(propName, propType) ->+ reportError $+ "Unrecognized type \"" <> propType <> "\" for event interface property \""+ <> propName <> "\" of interface \"" <> interfaceName <> "\""+ <>": must be one of ["+ <> intercalate ", " (map show (HashMap.keys interfaceTypes))+ <> "]"+ pure []++mkEnumGEqInstance :: Name -> [Con] -> Q Dec+mkEnumGEqInstance name cons = do+ true <- [|Just Refl|]+ false <- [|Nothing|]+ clauses <- for cons \(GadtC [con] _ _) ->+ pure (Clause [ConP con [], ConP con []] (NormalB true) [])+ let defaultClause = Clause [WildP, WildP] (NormalB false) []+ dec <- instanceD (pure []) [t|GEq $(conT name)|]+ [pure (FunD 'geq (clauses <> [defaultClause]))]+ pure dec++mkEnumGCompareInstance :: Name -> [Con] -> Q Dec+mkEnumGCompareInstance name cons = do+ arg1 <- newName "a"+ arg2 <- newName "b"+ cases <- for (diagonalize cons)+ \(less, GadtC [con] _ _, greater) ->+ match (conP con []) (normalB (caseE (varE arg2)+ (concat [ map (\(GadtC [l] _ _) -> match (conP l []) (normalB [|GLT|]) []) less+ , [ match (conP con []) (normalB [|GEQ|]) [] ]+ , map (\(GadtC [g] _ _) -> match (conP g []) (normalB [|GGT|]) []) greater ]))) []+ dec <- instanceD (pure []) [t|GCompare $(conT name)|]+ [funD 'gcompare [clause [varP arg1, varP arg2]+ (normalB (caseE (varE arg1) (pure <$> cases))) []]]+ pure dec++mkEncodeEventType :: [(String, Con)] -> Q [Dec]+mkEncodeEventType cons = do+ sig <- sigD encodeEventTypeName [t|forall d. $(conT eventTypeName) d -> ByteString|]+ dec <- funD encodeEventTypeName+ [ clause [conP con []] (normalB (litE (stringL string))) []+ | (string, GadtC [con] _ _) <- cons ]+ let prag = PragmaD (InlineP encodeEventTypeName Inline FunLike AllPhases)+ pure [sig, dec, prag]++-- | Make the @decodeEventProperties@ function+mkDecodeEventProperties :: [Con] -> Q [Dec]+mkDecodeEventProperties cons = do+ let event = pure (ConT eventTypeName)+ let cases = flip map cons \(GadtC [con] _ _) ->+ match (conP con []) (normalB [|JSON.eitherDecode|]) []+ sig <- sigD decodeEventPropertiesName [t| forall d. $event d -> ByteString -> Either String d|]+ arg <- newName "event"+ dec <- funD decodeEventPropertiesName+ [clause [varP arg] (normalB (caseE (varE arg) cases)) []]+ let prag = PragmaD (InlineP decodeEventPropertiesName Inline FunLike AllPhases)+ pure [sig, dec, prag]++mkDecodeSomeEventType :: [(String, Con)] -> Q [Dec]+mkDecodeSomeEventType cons = do+ allEvents <- newName "allEvents"+ let list =+ [ [|($(litE (stringL string)), Some $(conE con))|]+ | (string, GadtC [con] _ _) <- cons ]+ allEventsSig <- sigD allEvents [t|HashMap ByteString (Some $(conT eventTypeName))|]+ allEventsDec <- funD allEvents [clause [] (normalB [|HashMap.fromList $(listE list)|]) []]+ sig <- sigD decodeSomeEventTypeName+ [t| ByteString -> Maybe (Some $(conT eventTypeName))|]+ dec <- funD decodeSomeEventTypeName+ [clause [] (normalB [|flip HashMap.lookup $(varE allEvents)|])+ [pure allEventsSig, pure allEventsDec]]+ pure [sig, dec]++-- | Given an interface and a property for it, rename that property if necessary+-- to avoid clashing with reserved Haskell keywords+avoidKeywordProp :: String -> String -> String+avoidKeywordProp interface propName+ | HashSet.member propName keywords =+ onFirst Char.toLower (removeMatchingTail "Event" interface)+ <> onFirst Char.toUpper propName+ | otherwise = propName+ where+ removeMatchingTail m i =+ let reversed = reverse i+ in if m == reverse (take (length m) reversed)+ then reverse (drop (length m) reversed)+ else i++-- | Apply a function to the first element of a list+onFirst :: (a -> a) -> [a] -> [a]+onFirst _ [] = []+onFirst f (c:cs) = f c : cs++-- | Get all zipper positions into a list+diagonalize :: [a] -> [([a], a, [a])]+diagonalize [] = []+diagonalize (a : as) = go ([], a, as)+ where+ go :: ([a], a, [a]) -> [([a], a, [a])]+ go (l, c, []) = [(l, c, [])]+ go current@(l, c, r:rs) = current : go (c:l, r, rs)++-- | All reserved keywords in Haskell, including all extensions+-- Source: https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L875-L934+keywords :: HashSet String+keywords = HashSet.fromList+ ["as", "case", "class", "data", "default", "deriving", "do", "else", "hiding",+ "if", "import", "in", "infix", "infixl", "infixr", "instance", "let",+ "module", "newtype", "of", "qualified", "then", "type", "where", "forall",+ "mdo", "family", "role", "pattern", "static", "stock", "anyclass", "via",+ "group", "by", "using", "foreign", "export", "label", "dynamic", "safe",+ "interruptible", "unsafe", "stdcall", "ccall", "capi", "prim", "javascript",+ "unit", "dependency", "signature", "rec", "proc"]
+ src/Myxine/Page.hs view
@@ -0,0 +1,369 @@+{-# language BlockArguments, NamedFieldPuns, OverloadedStrings,+ ScopedTypeVariables, TypeApplications, LambdaCase #-}+{-# options_haddock not-home #-}++module Myxine.Page+ (+ -- * #Top# Creating Interactive Pages+ {-| To create an interactive page, we need to build a 'Page'. A 'Page' is a+ handle to a running page in the browser, providing a stateful typed+ mapping between the view and interactions in the browser page and the+ types and actions available within Haskell. To create a 'Page', we use+ 'runPage'. The beginning of a typical @myxine-client@ app looks something+ like:++@+type Model = ...++do page <- 'runPage' location initialModel handlers draw+ ...+ finalModel <- 'waitPage' page+ ...+where+ location :: 'PageLocation'+ location = 'pagePort' ... <> 'pagePath' ... -- where to connect to the server++ initialModel :: Model+ initialModel = ... -- model++ handlers :: 'Handlers'+ handlers = ... -- controller++ draw :: Model -> 'PageContent'+ draw = ... -- view+@++ To describe the interactive behavior of the page, we need to define:++ * @location@: the 'pagePath' and 'pagePort' to connect to the Myxine+ server. Use 'mempty' to use the default port and the root path. See the+ section on [page locations](#Locations).++ * @initialModel@: the starting value for the model of the page, which can+ be any Haskell data type of your choice.++ * @handlers@: the set of 'Handlers' for page events, which describe how to+ react to events like mouse clicks, form inputs, and more. A handler can+ modify the model of the page, and perform arbitrary 'IO' actions (though+ of course it's better style to be as pure as you can). After each+ handler is invoked, the page is immediately re-rendered to the browser+ if the model has changed. See the sections on [handling+ events](#Handling) and [manipulating pages](#Manipulating).++ * @draw@: a pure function mapping from the current state of the page's+ model to a rendered HTML view of the page in its entirety. This function+ will be called on every update to the model, so it's good to make it+ reasonably fast. This library takes an agnostic approach to HTML+ generation: it's up to you to create some 'PageContent' by generating+ some 'Data.Text.Text'. I recommend the+ [@blaze-html@](https://hackage.haskell.org/package/blaze-html) package+ for this purpose, but you can do this however you like. See the section+ on [rendering page views](#Rendering).+ -}+ Page, runPage, waitPage, stopPage++ -- * #Locations# Specifying Page Locations+ {-| If you are building a single-page application using Myxine, and you don't+ intend to share its address space, you don't need to change the default+ settings for the 'PageLocation': 'mempty' will do. However, the Myxine+ server will gladly host your page at any path you desire; just use+ 'pagePath' to specify. Similarly, use 'pagePort' to specify if the Myxine+ server is running on a different port than its default of 1123.+ -}+ , PageLocation, pagePath, pagePort++ -- * #Handling# Handling Events+ {-| In order to react to user events in the browser, we need to specify what+ effect each event of interest should have on the model in our 'Page'. To+ do this, 'runPage' asks that we construct up-front a set of 'Handlers'+ describing this.++ 'Handlers' is a 'Monoid': the 'mempty' 'Handlers' listens to no events+ (and therefore the only way for a page initialized this way to change is+ via 'modifyPage' and similar). Singleton 'Handlers' can be created using+ the 'on' function, and they can be joined together using their 'Monoid'+ instance.+ -}+ , Handlers, on+ , module Myxine.Target++ -- * #Manipulating# Manipulating Running Pages+ {-| Once a page is running, the only way to interact with its contents is via its+ 'Page' handle (unless you use the methods in 'Myxine.Direct', but it is+ /strongly discouraged/ to mix the two different abstractions: you will+ almost certainly confuse yourself a lot).++ A 'Page' whose behavior relies solely on user interactions within the+ browser doesn't need any of these functions: these are the mechanism by+ which external information can be used to modify the model of a page, and+ thereby update the GUI to reflect the model.++ Keep in mind that Myxine, like most GUIs, is an inherently concurrent+ system, and this interface reflects that. In between direct modifications+ of the model with 'modifyPage' and its friends, the model may change+ arbitrarily due to event handlers (or other threads) taking actions upon+ it. However, it's guaranteed that any single modification is atomic, and+ that sequences of modifications are not re-ordered (although there may be+ things that happen in between them).+ -}+ , modifyPage, modifyPageIO, setPage, getPage++ -- * #Rendering# Rendering Page Views+ {-| The Myxine server takes care of minimizing patches and re-draws in the+ browser. You merely need say how you want your model to be rendered, and+ let it take care of the rest.++ The @draw@ function required as the last argument to 'runPage' has the+ type @(model -> 'PageContent')@. As the library user, it's up to you how+ you want to render your model as 'Data.Text.Text'. Then, just wrap your+ desired @body@ contents with a call to 'pageBody' (and optionally+ combine this via 'Semigroup' with a call to 'pageTitle' to set the+ @title@), and return the resultant 'PageContent'.+ -}+ , PageContent, pageBody, pageTitle++ -- * #Evaluating# Evaluating Raw JavaScript+ {-| It occasionally might become necessary for you to directly evaluate some+ JavaScript within the context of the browser. The most frequent reason for+ this is to query the value of some object, such as the current contents of+ a text-box, or the current window dimensions. The 'evalInPage' function is+ precisely the escape hatch to enable this. Here's how you might get the+ current window width of the browser window:++@+do Right width <- evalInPage (JsExpression "window.innerWidth")+ print (width :: Int)+@+ -}+ , JavaScript(..), evalInPage+ ) where++import Control.Monad+import Data.IORef+import Control.Exception (SomeException, throwIO)+import qualified Control.Exception as Exception+import qualified Data.Aeson as JSON+import Control.Concurrent++import Myxine.Direct+import Myxine.Target (Target, tag, attribute)+import Myxine.Handlers++-- | A handle to a running 'Page'. Create this using 'runPage', and wait for its+-- eventual result using 'waitPage'. In between, you can interact with it using+-- the rest of the functions in this module, such as 'modifyPage', 'stopPage',+-- etc.+data Page model+ = Page+ { pageActions :: !(Chan (Maybe (model -> IO model)))+ , pageFinished :: !(MVar (Either SomeException model))+ , pageLocation :: !PageLocation+ , pageEventThread :: !ThreadId }++-- | Run an interactive page, returning a handle 'Page' through which it can be+-- interacted further, via the functions in this module (e.g. 'waitPage',+-- 'modifyPage', etc.).+--+-- This function itself is non-blocking: it immediately kicks off threads to+-- start running the page. It will not throw exceptions by itself. All+-- exceptions thrown by page threads (such as issues with connecting to the+-- server) are deferred until a call to 'waitPage'.+--+-- __Important:__ Because the GHC runtime does not wait for all threads to+-- finish when ending the main thread, you probably need to use 'waitPage' to+-- make sure your program stays alive to keep processing events.+runPage :: forall model.+ PageLocation+ {- ^ The location of the 'Page' ('pagePort' and/or 'pagePath') -} ->+ model+ {- ^ The initial @model@ of the model for the 'Page' -} ->+ Handlers model+ {- ^ The set of event 'Handlers' for events in the page -} ->+ (model -> PageContent)+ {- ^ A function to draw the @model@ as some rendered 'PageContent' (how you do this is up to you) -} ->+ IO (Page model)+ {- ^ A 'Page' handle to permit further interaction with the running page -}+runPage pageLocation initialModel handlers draw =+ do pageActions <- newChan -- channel for model-modifying actions+ pageFinished <- newEmptyMVar -- signal for the page's shutdown++ -- Loop through all the events on the page, translating them to events+ pageEventThread <- forkIO $+ flip Exception.finally (writeChan pageActions Nothing) $ -- tell model thread to stop+ Exception.handle (putMVar pageFinished . Left) $ -- finished with exception+ Exception.handle @Exception.AsyncException (const (pure ())) $ -- don't track when the thread is killed+ do writeChan pageActions (Just redraw)+ withEvents pageLocation+ (Just (handledEvents handlers))+ \event properties targets ->+ writeChan pageActions . Just $+ redraw <=< handle handlers event properties targets++ -- Loop through all the actions, doing them+ _pageModelThread <- forkIO+ do model <- newIORef initialModel -- current model of the page+ Exception.handle (putMVar pageFinished . Left) $+ let loop = readChan pageActions >>= \case+ Nothing -> putMVar pageFinished . Right =<< readIORef model+ Just action ->+ do writeIORef model =<< action =<< readIORef model+ loop+ in loop++ pure (Page { pageActions, pageLocation, pageFinished, pageEventThread })++ where+ redraw :: model -> IO model+ redraw model =+ do let pageContent = draw model+ sendUpdate pageLocation (Dynamic pageContent)+ pure model++-- | Wait for a 'Page' to finish executing and return its resultant @model@, or+-- re-throw any exception the page encountered.+--+-- This function may throw 'Req.HttpException' if it cannot connect to a running+-- instance of the server. Additionally, it will also re-throw any exception+-- that was raised by user code running within an event handler or+-- model-modifying action.+waitPage :: Page model -> IO model+waitPage Page{pageFinished, pageEventThread} =+ do result <- readMVar pageFinished+ killThread pageEventThread+ either throwIO pure result++-- | Politely request a 'Page' to shut down. This is non-blocking: to get the+-- final model of the 'Page', follow 'stopPage' with a call to 'waitPage'.+--+-- Before the page is stopped, all events and modifications which were pending+-- at the time of this command will be processed.+stopPage :: Page model -> IO ()+stopPage Page{pageActions} =+ writeChan pageActions Nothing++-- | Modify the model of the page with a pure function, and update the view in+-- the browser to reflect the new model.+--+-- This is non-blocking: it is not guaranteed that when this call returns, the+-- browser is now showing the new view. However, sequential calls to+-- 'modifyPage', 'modifyPageIO', 'setPage', 'getPage', 'evalInPage', and+-- 'stopPage' are guaranteed to be executed in the order they were issued.+modifyPage :: Page model -> (model -> model) -> IO ()+modifyPage page f = modifyPageIO page (pure . f)++-- | Modify the model of the page, potentially doing arbitrary other effects in+-- the 'IO' monad, then re-draw the page to the browser. Special cases include:+-- 'modifyPage' and 'setPage'.+--+-- This is non-blocking: it is not guaranteed that when this call returns, the+-- browser is now showing the new view. However, sequential calls to+-- 'modifyPage', 'modifyPageIO', 'setPage', 'getPage', 'evalInPage', and+-- 'stopPage' are guaranteed to be executed in the order they were issued.+modifyPageIO :: Page model -> (model -> IO model) -> IO ()+modifyPageIO Page{pageActions} action =+ writeChan pageActions (Just action)++-- | Set the model of the page to a particular value, and update the view in the+-- browser to reflect the new model.+--+-- This is non-blocking: it is not guaranteed that when this call returns, the+-- browser is now showing the new view. However, sequential calls to+-- 'modifyPage', 'modifyPageIO', 'setPage', 'getPage', 'evalInPage', and+-- 'stopPage' are guaranteed to be executed in the order they were issued.+setPage :: Page model -> model -> IO ()+setPage page = modifyPage page . const++-- | Get the current model of the page, blocking until it is retrieved.+--+-- Sequential calls to 'modifyPage', 'modifyPageIO', 'setPage', 'getPage',+-- 'evalInPage', and 'stopPage' are guaranteed to be executed in the order they+-- were issued.+--+-- __Note:__ it is not guaranteed that the model returned by this function is+-- "fresh" by the time you act upon it. That is:+--+-- @+-- 'getPage' page >>= 'setPage' page+-- @+--+-- __is not the same as__+--+-- @+-- 'modifyPage' id+-- @+--+-- This is because some other thread (notably, an event handler thread) could+-- have changed the page in between the call to 'getPage' and 'setPage'. As a+-- result, you probably don't want to use this function, except perhaps as a way+-- to extract intermediate reports on the value of the page.+getPage :: Page model -> IO model+getPage page = do+ v <- newEmptyMVar+ modifyPageIO page \model ->+ do putMVar v model+ pure model+ takeMVar v++-- | Evaluate some 'JavaScript' in the context of a running 'Page', blocking+-- until the result is returned.+--+-- Returns either a deserialized Haskell type, or a human-readable string+-- describing any error that occurred. Possible errors include:+--+-- * Any exception in the given JavaScript+--+-- * Absence of any browser window currently viewing the page (since there's no+-- way to evaluate JavaScript without a JavaScript engine)+--+-- * Evaluation timeout (default is 1000 milliseconds, but can be overridden in+-- the timeout parameter to this function+--+-- * Invalid JSON response for the result type inferred (use 'JSON.Value' if you+-- don't know what shape of data you're waiting to receive).+--+-- Further caveats:+--+-- * JavaScript @undefined@ is translated to @null@ in the results+--+-- * 'JsBlock' inputs which don't explicitly return a value result in @null@+--+-- * Return types are limited to those which can be serialized via+-- [@JSON.stringify@](https://developer.mozilla.org/docs/Web/JavaScript/Reference/Global_Objects/JSON/stringify),+-- which does not work for cyclic objects (like @window@, @document@, and all+-- DOM nodes), and may fail to serialize some properties for other non-scalar+-- values. If you want to return a non-scalar value like a list or dictionary,+-- construct it explicitly yourself by copying from the fields of the object+-- you're interested in.+--+-- Keep in mind that this feature has sharp edges, and is usually+-- unnecessary. In particular:+--+-- * You're evaluating an arbitrary string as JavaScript, which means there+-- are no guarantees about type safety or purity.+--+-- * It is possible that you could break the Myxine server code running in+-- the page that makes it update properly, or hang the page by passing a+-- non-terminating piece of code.+--+-- * Any modifications you make to the DOM will be immediately overwritten on+-- the next re-draw of the page. Don't do this.+--+-- * If there are multiple browser windows pointed at the same page, and the+-- result of your query differs between them, it's nondeterministic which+-- result you get back.+--+-- Sequential calls to 'modifyPage', 'modifyPageIO', 'setPage', 'getPage',+-- 'evalInPage', and 'stopPage' are guaranteed to be executed in the order they+-- were issued.+evalInPage ::+ JSON.FromJSON a =>+ Page model {- ^ The 'Page' in which to evaluate the JavaScript -} ->+ Maybe Int {- ^ An optional override for the default timeout of 1000 milliseconds -} ->+ JavaScript {- ^ The JavaScript to evaluate: either a 'JsExpression' or a 'JsBlock' -} ->+ IO (Either String a)+evalInPage page@Page{pageLocation} timeout js =+ do v <- newEmptyMVar+ modifyPageIO page \model ->+ do putMVar v =<< evaluateJs pageLocation timeout js+ pure model+ takeMVar v
+ src/Myxine/Target.hs view
@@ -0,0 +1,33 @@+{-# language NamedFieldPuns, DeriveGeneric, DeriveAnyClass #-}+{-# options_haddock not-home #-}++module Myxine.Target (Target, attribute, tag) where++import Data.Text (Text)+import qualified Data.Aeson as JSON+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HashMap+import GHC.Generics++-- | A 'Target' is a description of a single element node in the browser. When+-- an event fires in the browser, Myxine tracks the path of nodes it touches,+-- from the most specific element all the way up to the root. Each event handler+-- is given access to this @['Target']@, ordered from most to least specific.+--+-- For any 'Target', you can query the value of any of an 'attribute', or you+-- can ask for the 'tag' of that element.+data Target = Target+ { tagName :: Text+ , attributes :: HashMap Text Text+ } deriving (Eq, Ord, Show, Generic, JSON.FromJSON)++-- | Get the value, if any, of some named attribute of a 'Target'.+attribute :: Text -> Target -> Maybe Text+attribute name Target{attributes} = HashMap.lookup name attributes+{-# INLINE attribute #-}++-- | Get the name of the HTML tag for this 'Target'. Note that unlike in the+-- browser itself, Myxine returns tag names in lower case, rather than upper.+tag :: Target -> Text+tag Target{tagName} = tagName+{-# INLINE tag #-}
+ test/Test.hs view
@@ -0,0 +1,4 @@+module Main (main) where++main :: IO ()+main = putStrLn "Test suite not yet implemented."