diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. 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/enabled-events.json b/enabled-events.json new file mode 100644 --- /dev/null +++ b/enabled-events.json @@ -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", + "inputType": "Option", + "isComposing": "Option" + } + }, + "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", + "screenX": "f64", + "screenY": "f64", + "shiftKey": "bool" + } + }, + "UIEvent": { + "inherits": "Event", + "properties": { + "detail": "Option" + } + }, + "WheelEvent": { + "inherits": "MouseEvent", + "properties": { + "deltaMode": "i64", + "deltaX": "f64", + "deltaY": "f64", + "deltaZ": "f64" + } + } + } +} diff --git a/myxine-client.cabal b/myxine-client.cabal new file mode 100644 --- /dev/null +++ b/myxine-client.cabal @@ -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 diff --git a/src/Myxine.hs b/src/Myxine.hs new file mode 100644 --- /dev/null +++ b/src/Myxine.hs @@ -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) diff --git a/src/Myxine/Direct.hs b/src/Myxine/Direct.hs new file mode 100644 --- /dev/null +++ b/src/Myxine/Direct.hs @@ -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 +-- . 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 diff --git a/src/Myxine/Event.hs b/src/Myxine/Event.hs new file mode 100644 --- /dev/null +++ b/src/Myxine/Event.hs @@ -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") diff --git a/src/Myxine/Handlers.hs b/src/Myxine/Handlers.hs new file mode 100644 --- /dev/null +++ b/src/Myxine/Handlers.hs @@ -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) diff --git a/src/Myxine/Internal/EventStream.hs b/src/Myxine/Internal/EventStream.hs new file mode 100644 --- /dev/null +++ b/src/Myxine/Internal/EventStream.hs @@ -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 diff --git a/src/Myxine/Internal/TH.hs b/src/Myxine/Internal/TH.hs new file mode 100644 --- /dev/null +++ b/src/Myxine/Internal/TH.hs @@ -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", [t|Maybe Double|]) + , ("Option", [t|Maybe Int|]) + , ("Option", [t|Maybe Text|]) + , ("Option", [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"] diff --git a/src/Myxine/Page.hs b/src/Myxine/Page.hs new file mode 100644 --- /dev/null +++ b/src/Myxine/Page.hs @@ -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 diff --git a/src/Myxine/Target.hs b/src/Myxine/Target.hs new file mode 100644 --- /dev/null +++ b/src/Myxine/Target.hs @@ -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 #-} diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = putStrLn "Test suite not yet implemented."