myxine-client 0.0.0.2 → 0.0.1.0

raw patch · 14 files changed

+1291/−577 lines, 14 filesdep +asyncdep +blaze-htmldep +blaze-markupdep −dependent-sumdep ~dependent-mapdep ~reqdep ~template-haskellPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: async, blaze-html, blaze-markup, constraints, containers, lens, modern-uri, mtl, salve, some, spoon

Dependencies removed: dependent-sum

Dependency ranges changed: dependent-map, req, template-haskell

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• enabled-events.json +0/−8
• myxine-client.cabal +32/−17
• src/Myxine.hs +11/−32
• src/Myxine/ConjMap.hs +68/−0
• src/Myxine/Direct.hs +308/−169
• src/Myxine/Event.hs +23/−6
• src/Myxine/Handlers.hs +143/−35
• src/Myxine/Internal/Event.hs +10/−0
• src/Myxine/Internal/EventStream.hs +0/−92
• src/Myxine/Internal/TH.hs +12/−7
• src/Myxine/Page.hs +351/−209
• src/Myxine/Reactive.hs +315/−0
• src/Myxine/Target.hs +17/−1

@@ -1,6 +1,6 @@ MIT License -Copyright (c) 2019 Galois, Inc.+Copyright (c) 2019 Galois, Inc. and Kenny Foner  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal

@@ -229,14 +229,6 @@                 "select"             ]         },-        "selectionchange": {-            "bubbles": false,-            "interface": "Event",-            "nameWords": [-                "selection",-                "change"-            ]-        },         "submit": {             "bubbles": true,             "interface": "Event",

@@ -1,9 +1,9 @@ cabal-version:       2.4 name:                myxine-client-version:             0.0.0.2+version:             0.0.1.0 synopsis:            A Haskell client for the Myxine GUI server homepage:            https://github.com/GaloisInc/myxine-bug-reports:         https://github.com/GaloisInc/myxine/issues+bug-reports:         https://github.com/GaloisInc/myxine/issues/new license:             MIT license-file:        LICENSE author:              Kenny Foner@@ -28,31 +28,37 @@   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@+  __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.+  __@NamedFieldPuns@__ and __@RecordWildCards@__.  common deps   build-depends:       base                 >= 4.12.0.0 && <= 4.14.0.0,-                       req                  ^>= 3.1,+                       req                  >= 3.1 && <= 3.3,                        aeson                ^>= 1.4,                        text                 ^>= 1.2,+                       mtl                  ^>= 2.2,                        transformers         ^>= 0.5,                        bytestring           ^>= 0.10,                        unordered-containers ^>= 0.2,-                       dependent-map        ^>= 0.3,-                       dependent-sum        ^>= 0.6,-                       template-haskell     >= 2.14.0.0 && <= 2.15.0.0,+                       containers           ^>= 0.6,+                       dependent-map        ^>= 0.4,+                       some                 ^>= 1.0,+                       template-haskell     >= 2.14.0.0 && <= 2.16.0.0,                        hashable             ^>= 1.3,                        file-embed           ^>= 0.0.11.1,                        http-client          ^>= 0.6,-                       http-types           ^>= 0.12+                       http-types           ^>= 0.12,+                       modern-uri           ^>= 0.3,+                       constraints          >= 0.10 && <= 0.12,+                       salve                ^>= 1.0,+                       blaze-markup         ^>= 0.8,+                       blaze-html           ^>= 0.9,+                       spoon                ^>= 0.3,+                       async                ^>= 2.2,+                       lens                 ^>= 4.19  common options   default-language:    Haskell2010@@ -70,12 +76,19 @@                        DeriveGeneric,                        DerivingStrategies,                        DerivingVia,+                       DeriveFunctor,+                       DeriveFoldable,+                       DeriveTraversable,                        DuplicateRecordFields,+                       RecordWildCards,                        EmptyCase,+                       FlexibleInstances,+                       FlexibleContexts,                        GADTs,                        GeneralizedNewtypeDeriving,                        KindSignatures,                        LambdaCase,+                       MultiParamTypeClasses,                        NamedFieldPuns,                        OverloadedStrings,                        RankNTypes,@@ -89,13 +102,15 @@ library   import:              deps, options   exposed-modules:     Myxine+                       Myxine.Event                        Myxine.Direct-  other-modules:       Myxine.Page-                       Myxine.Target                        Myxine.Handlers-                       Myxine.Event-                       Myxine.Internal.EventStream+  other-modules:       Myxine.Reactive+                       Myxine.Page+                       Myxine.Target+                       Myxine.ConjMap                        Myxine.Internal.TH+                       Myxine.Internal.Event                        Paths_myxine_client   autogen-modules:     Paths_myxine_client   hs-source-dirs:      src

@@ -7,48 +7,27 @@     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.+    This module defines a higher level interface 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+  ( -- ** Required Extensions+{-| This library relies on the extension __@OverloadedRecordFields@__, since a+variety of browser event interfaces share field names/types. Without enabling+it, you'll see many bewildering errors about ambiguous names. --- | 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+You may also find useful for concision the extensions __@NamedFieldPuns@__ and+__@RecordWildCards@__.+-}+    module Myxine.Page+  , module Myxine.Event   ) where  import Myxine.Event import Myxine.Direct import Myxine.Page-import qualified Myxine.Event as Event-  hiding (decodeSomeEventType, decodeEventProperties, encodeEventType)

@@ -0,0 +1,68 @@+module Myxine.ConjMap+  ( ConjMap+  , empty+  , lookup+  , insert+  , union+  ) where++import Prelude hiding (lookup)+import Data.Maybe+import Data.Hashable+import qualified Data.HashSet as HashSet+import qualified Data.HashMap.Strict as HashMap+import Data.HashMap.Strict (HashMap)++data ConjMap k a+  = ConjMap [a] (HashMap k (ConjMap k a))+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++empty :: ConjMap k a+empty = ConjMap [] HashMap.empty++-- | Retrieve all items whose keys are a (non-strict) subset of the specified+-- keys.+lookup :: (Eq k, Hashable k) => [k] -> ConjMap k a -> [a]+lookup = go . HashSet.fromList+  where+    go facts (ConjMap universal specific) =+      universal <> fromMaybe [] (goSpecific facts specific)++    goSpecific facts specific =+      foldMap (\fact -> go (HashSet.delete fact facts) <$>+                           HashMap.lookup fact specific) facts++-- | Add an item such that it can be retrieved only by giving a (non-strict)+-- superset of all the specified keys.+insert :: (Eq k, Hashable k) => [k] -> a -> ConjMap k a -> ConjMap k a+insert patList a =+  goTree (HashSet.fromList patList)+  where+    -- Invariant: no pattern appears twice in a branch of a tree, although it+    -- can occur multiple times in separate branches+    goTree pats (ConjMap universal specific)+      | HashSet.null pats = ConjMap (a : universal) specific+      | otherwise = ConjMap universal (goNodes pats (HashMap.toList specific))++    goNodes pats [] = freshNode pats+    goNodes pats ((k, t) : rest)+      | HashSet.member k pats =+        HashMap.fromList ((k, goTree (HashSet.delete k pats) t) : rest)+      | otherwise =+        HashMap.insert k t (goNodes pats rest)++    freshNode (HashSet.toList -> pats) = freshNode' pats+      where+        freshNode' []       = error "Internal error: addMatch: [] passed to freshNode"+        freshNode' [p]      = HashMap.singleton p (ConjMap [a] HashMap.empty)+        freshNode' (p : ps) = HashMap.singleton p (ConjMap [] (freshNode' ps))++union :: (Eq k, Hashable k) => ConjMap k a -> ConjMap k a -> ConjMap k a+union (ConjMap u s) (ConjMap u' s') =+  ConjMap (u <> u') (HashMap.unionWith union s s')++instance (Eq k, Hashable k) => Semigroup (ConjMap k a) where+  (<>) = union++instance (Eq k, Hashable k) => Monoid (ConjMap k a) where+  mempty = empty

@@ -7,87 +7,53 @@ 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+can send a new page 'Update' using 'update', you can loop over all page+events using 'events', 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+    -- * Sending updates to pages and getting events from pages+  , Update(..), EventList(..), PageEvent(..), Target, tag, attribute+  , PageContent, pageBody, pageTitle, pageContentBody, pageContentTitle+  , update, events     -- * Evaluating raw JavaScript in the context of a page-  , JavaScript(..), evaluateJs-    -- * Exceptions-  , EventParseException(..)-  , -- * The @Some@ existential+  , JavaScript(..), evaluateJs, JsException(..)+    -- * Exceptions thrown if the server misbehaves+  , ProtocolException(..)+    -- * The @Some@ existential+  , Some(..)+  , module Myxine.Event   ) where  import Data.Maybe+import Control.Monad import Data.Monoid import Data.String-import Control.Monad-import Control.Concurrent import Data.List+import Data.List.NonEmpty (NonEmpty(..))+import Control.Monad.IO.Class import Control.Exception-import Data.Dependent.Map (Some(..))+import Data.Constraint+import Data.Some.Newtype (Some(..))+import qualified Data.ByteString.Char8 import qualified Data.ByteString.Lazy.Char8 as ByteString import Data.ByteString.Lazy.Char8 (ByteString) import Data.Text (Text)+import Data.IORef 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 qualified Text.URI as URI+import qualified Salve+import Data.Version (showVersion) +import Myxine.Internal.Event 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"+import Paths_myxine_client (version)  -- | The view of a page, as rendered in the browser. Create page content with -- 'pageBody' and 'pageTitle', and combine content using the 'Semigroup'@@ -97,8 +63,8 @@ -- 'pageTitle' (if any), and concatenates in order each specified 'pageBody'. data PageContent   = PageContent-    { pageContentBody  :: Text-    , pageContentTitle :: Last Text+    { _pageContentBody  :: Text+    , _pageContentTitle :: Last Text     } deriving (Eq, Ord, Show)  instance Semigroup PageContent where@@ -111,13 +77,21 @@ -- | Create a rendered 'PageContent' with an empty @title@ and the specified -- text as its @body@. pageBody :: Text -> PageContent-pageBody body = mempty { pageContentBody = body }+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) }+pageTitle title = mempty { _pageContentTitle = Last (Just title) } +-- | Get the rendered @body@ of a 'PageContent'.+pageContentBody :: PageContent -> Text+pageContentBody = _pageContentBody++-- | Get the @title@ of a 'PageContent'.+pageContentTitle :: PageContent -> Maybe Text+pageContentTitle = getLast . _pageContentTitle+ -- | A full page update as ready-to-send to the Myxine server. data Update   = Dynamic       -- ^ A dynamic page which can be updated live@@ -129,11 +103,14 @@     ByteString    -- ^ The raw bytes to be served by the server   deriving (Eq, Ord, Show) +host :: Text+host = "localhost"+ -- | 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)+  foldl' (Req./:) (Req.http host) (Text.split ('/' ==) p)  -- | A local port at which the server is expected to be running. Create one -- using an integer literal or 'fromInteger'.@@ -147,6 +124,7 @@   = PagePath Text   deriving newtype (IsString, Eq, Ord, Show) +-- TODO: Allow remote connections! -- | 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.@@ -178,28 +156,76 @@     { pageLocationPort = mempty     , pageLocationPath = mempty } +-- | A @PageEvent@ is an event that occurred in the browser: a triple of the+-- 'EventType', any associated properties of the event (this varies depending on+-- the event type), and the list of 'Target's of the event, in order from most+-- to least specific.+data PageEvent where+  PageEvent :: { event :: EventType props+               , properties :: props+               , targets :: [Target]+               } -> PageEvent++instance Show PageEvent where+  showsPrec d PageEvent{event, properties, targets} =+    case eventPropertiesDict event of+      Dict -> showParen (d > 10) $+        showString "PageEvent {event = " .+        showsPrec 0 event .+        showString ", properties = " .+        showsPrec 0 properties .+        showString ", targets = " .+        showsPrec 0 targets .+        showString "}"++instance JSON.FromJSON PageEvent where+  parseJSON = JSON.withObject "PageEvent" \o ->+    do eventName <- o JSON..: "event"+       Some event <-+         flip maybe pure+          (fail ("Unrecognized event: " <> Text.unpack eventName))+          (decodeSomeEventType eventName)+       Dict <- pure (eventPropertiesDict event)+       properties <- o JSON..: "properties"+       targets <- o JSON..: "targets"+       pure (PageEvent{event, properties, targets})++-- | A list of event types to listen for: either all events, or a specific list+-- of events.+data EventList+  = AllEvents  -- ^ Listen for all events+  | SomeEvents (NonEmpty (Some EventType))  -- ^ Listen only for these events+  deriving (Eq, Ord, Show)+ -- | 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 -} ->+update ::+  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)+update PageLocation{pageLocationPort = Last maybePort,+                        pageLocationPath = Last maybePath} updateContent =+  wrapCaughtReqException $+  do response <- Req.runReq Req.defaultHttpConfig $+       Req.req Req.POST url body Req.ignoreResponse options+     checkServerVersion response      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}) ->+    options =+      Req.port (maybe defaultPort (\(PagePort p) -> p) maybePort) <>+      Req.responseTimeout maxBound <>+      updateOptions++    body :: Req.ReqBodyLbs+    updateOptions :: Req.Option 'Req.Http+    (body, updateOptions) = case updateContent of+      Dynamic (PageContent{_pageContentTitle = Last maybeTitle,+                           _pageContentBody = text}) ->         ( Req.ReqBodyLbs (ByteString.fromStrict (Text.encodeUtf8 text))         , foldMap ("title" Req.=:) maybeTitle )       Static contentType content ->@@ -216,51 +242,78 @@   | JsBlock Text      -- ^ A block of JavaScript statements   deriving (Eq, Ord, Show) --- | Evaluate some raw JavaScript in the context of a given page+-- | An exception thrown by evaluating JavaScript. This may be a deserialization+-- error, or an error that occurred in the JavaScript runtime itself.+newtype JsException =+  JsException String+  deriving newtype (Eq, Ord, Show)+  deriving anyclass (Exception)++-- | 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:+-- Returns either a deserialized Haskell type, or throws a 'JsException'+-- containing a human-readable string describing any error that occurred. ----- * 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+-- Possible errors include:+--+-- Possible errors, which manifest as 'JsException's:+--+--   * Any exception in the given JavaScript+--+--   * 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),+--   * JavaScript @undefined@ is translated to @null@ in the results+--+--   * 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.+--+--   * 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.+ 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)+  IO 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))+                        pageLocationPath = Last maybePath} js =+  wrapCaughtReqException $+  do response <- Req.runReq Req.defaultHttpConfig $+       Req.req Req.POST url body Req.lbsResponse options+     checkServerVersion response+     if Req.responseStatusCode response == 200+       then either (throwIO . JsException) pure $+            JSON.eitherDecode (Req.responseBody response)+       else throwIO (JsException (ByteString.unpack (Req.responseBody response)))   where     url = pageUrl (fromMaybe "" maybePath)-    portOption = Req.port (maybe defaultPort (\(PagePort p) -> p) maybePort) +    options =+      Req.port (maybe defaultPort (\(PagePort p) -> p) maybePort) <>+      Req.responseTimeout maxBound <>+      exprOption+     body :: Req.ReqBodyLbs-    exprOption, timeoutOption :: Req.Option 'Req.Http-    timeoutOption = foldMap ("timeout" Req.=:) timeout+    exprOption :: Req.Option 'Req.Http     (body, exprOption) = case js of       JsExpression expr ->         (Req.ReqBodyLbs "", "evaluate" Req.=: expr)@@ -268,76 +321,162 @@         (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.+-- | Given a page location and list of events, create an IO action that acts as+-- a "stream" of sequential events matching the event list. The state maintained+-- within the stream is used to coordinate with the server to return a+-- sequential event from each poll of the stream. It is strongly recommended to+-- create only one such "get next" action and to poll it repeatedly. ----- 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 ::+-- Calls to the "get next" action returned will block until the next event+-- matching the given description is available. Provided that the "get next"+-- action is polled with sufficient frequency, no events will be missed, as the+-- server maintains an internal fixed-size buffer of events to distribute to+-- lagging clients. However, significantly lagging clients may observe dropped+-- events. It is therefore best practice to eagerly collect events in a separate+-- tight-looping thread and buffer them client-side.+events ::   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+    {- ^ The location of the page to listen for events from. -} ->+  IO (EventList -> IO PageEvent)+    {- ^ An action which polls for the next event matching the given list, and+         blocks until such an event arrives. -}+events PageLocation{pageLocationPort = Last maybePort,+                    pageLocationPath = Last maybePath} =+  do moment <- newIORef Nothing+     pure (\eventList -> wrapCaughtReqException $+            Req.runReq Req.defaultHttpConfig (go moment eventList))   where-    url = pageUrl (fromMaybe "" maybePath)-    portOption = Req.port (maybe defaultPort (\(PagePort p) -> p) maybePort)+    go :: IORef (Maybe Text) -> EventList -> Req.Req PageEvent+    go moment eventList =+      do currentMoment <- liftIO (readIORef moment)+         (url, options) <-+           maybe (liftIO . throwIO . MyxineProtocolException $+                  "Invalid Content-Location:" <> show currentMoment)+                 pure+                 (urlAndOptions currentMoment eventList)+         response <- Req.req Req.GET url Req.NoReqBody Req.jsonResponse options+         liftIO $ checkServerVersion response+         let nextMoment =+               Text.decodeUtf8 <$>+                 Req.responseHeader response "Content-Location"+         -- If any async exception happens before here, we won't increment the+         -- moment. We make sure that if an exception happens during the+         -- increment or the return, we roll back the increment before+         -- re-throwing the exception, which ensures this function is safe to+         -- use inside an Async task (that is, cancellation won't skip events).+         liftIO $ catch @SomeException+           (do writeIORef moment nextMoment+               pure (Req.responseBody response))+           (\e -> do+               writeIORef moment currentMoment+               throwIO e) -    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)+    urlAndOptions ::+      Maybe Text ->+      EventList ->+      Maybe (Req.Url 'Req.Http, Req.Option 'Req.Http)+    urlAndOptions maybeMoment eventList =+      case maybeMoment of+        Nothing ->+          pure (pageUrl (fromMaybe "" maybePath), fixedOptions)+        Just moment ->+          -- Parse the URI given and make it absolute to the server+          do URI.URI { uriScheme,+                       uriAuthority,+                       uriPath,+                       uriQuery,+                       uriFragment } <- URI.mkURI moment+             -- Fill in the default scheme and authority if absent+             let uriScheme' = Just $+                   maybe (fromJust (URI.mkScheme "http")) id uriScheme+                 uriAuthority' = Right $+                   either (const $+                           URI.Authority { authUserInfo = Nothing+                                         , authHost = fromJust (URI.mkHost host)+                                         , authPort = Nothing })+                          id+                          uriAuthority+                 uri = URI.URI { uriScheme = uriScheme'+                               , uriAuthority = uriAuthority'+                               , uriPath+                               , uriQuery+                               , uriFragment }+             -- Parse into Req's way of seeing the world+             (url, momentOption) <- Req.useHttpURI uri+             pure (url, fixedOptions <> momentOption)+      where+        fixedOptions :: Req.Option 'Req.Http+        fixedOptions =+          portOption <> eventParams <> Req.queryFlag "next"+          <> Req.responseTimeout maxBound  -- important, because long-polling! --- | 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))+        portOption :: Req.Option 'Req.Http+        portOption = Req.port (maybe defaultPort (\(PagePort p) -> p) maybePort) --- | 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+        eventParams :: Req.Option 'Req.Http+        eventParams = case eventList of+          AllEvents -> Req.queryFlag "events"+          SomeEvents es -> flip foldMap es+            \(Some e) -> "event" Req.=: ByteString.unpack (encodeEventType e)++wrapCaughtReqException :: IO a -> IO a+wrapCaughtReqException action =+  catch @Req.HttpException action $+  \case+    Req.VanillaHttpException e -> throwIO e+    Req.JsonHttpException message -> throwIO (MyxineProtocolException message)++-- | If the response from the server cannot be processed appropriately, 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 ProtocolException+  = MyxineProtocolException String+  | MyxineServerVersionClashException Salve.Version+  | MyxineUnknownServerException+  deriving stock (Eq, Ord)+  deriving anyclass (Exception)++-- | The supported versions of the Myxine server for this version of the client+-- library. This needs to be bumped whenever the library is updated to match a+-- new server release.+supportedServers :: Salve.Constraint+supportedServers = Salve.unsafeParseConstraint ">=0.2.0 <0.3.0"++-- | Check a response to ensure that it originated from a server which describes+-- itself as being the correct server version for this client library. If this+-- check fails, throw an exception; otherwise, do nothing.+checkServerVersion :: Req.HttpResponse response => response -> IO ()+checkServerVersion response =+  case Data.ByteString.Char8.split '/' <$> Req.responseHeader response "server" of+    Nothing -> throwIO MyxineUnknownServerException+    Just ["myxine", versionString] ->+      case Salve.parseVersion (Data.ByteString.Char8.unpack (versionString <> ".0")) of+        Nothing -> throwIO MyxineUnknownServerException+        Just serverVersion ->+          when (not (Salve.satisfiesConstraint supportedServers serverVersion)) $+          throwIO (MyxineServerVersionClashException serverVersion)+    _ -> throwIO MyxineUnknownServerException++instance Show ProtocolException where+  show MyxineUnknownServerException =+       "*** Refusing to connect to a server that doesn't self-identify as a Myxine server.\n"+    <> "Ensure that the address and port are correct and try again."+  show (MyxineServerVersionClashException serverVersion) =+       "*** Myxine client/server version mismatch: myxine-client library " <> showVersion version+    <> " is incompatible with myxine server version " <> Salve.renderVersion serverVersion <> ".\n"+    <> "Either connect to a server in the compatible range of " <> Salve.renderConstraint supportedServers <> ","+    <> " or update this application to use a compatible client library version."+  show (MyxineProtocolException details) =+       "*** Myxine client panic: Failed to process event!\n"+    <> "This likely means there is a bug in the Myxine server or client library.\n"+    <> "Please file a bug report at: " <> bugReportURL <> ".\n"+    <> "Please include the version of this library (" <> showVersion version <> "), "+    <> "and the following error message: \n" <> details+    where+      bugReportURL :: String+      bugReportURL = "https://github.com/GaloisInc/myxine/issues/new"

@@ -1,10 +1,27 @@+{- | Description : Types and properties of browser 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).+-} {-# language StrictData #-} {-# options_ghc -Wno-name-shadowing -Wno-unused-matches #-}-{-# options_haddock not-home #-} -module Myxine.Event where--import Data.FileEmbed-import Myxine.Internal.TH+module Myxine.Event (module Myxine.Internal.Event) where -mkEventsAndInterfaces $(embedFile "enabled-events.json")+import Myxine.Internal.Event hiding+  (decodeSomeEventType, eventPropertiesDict, encodeEventType)

@@ -1,62 +1,160 @@-module Myxine.Handlers (Handlers, on, handle, handledEvents) where+{-| Description : Declarative handlers for page events (usually not necessary+  unless you're making an alternative to the 'Myxine.Reactive' builder) +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 'Myxine.Page'. To do+this, 'Myxine.runPage' asks that we construct up-front a set of 'Handlers'+describing this.++'Handlers' is a 'Monoid': the 'mempty' 'Handlers' listens to no events.+Singleton 'Handlers' can be created using the 'onEvent' function, and they can+be joined together using '<>'.++This module is useful when you are building your own page event handling+abstraction, for instance, if 'Myxine.Reactive' isn't right for your purposes.+However, it is not necessary to use this module directly if you are building a+reactive page using that high-level abstraction.+-}++module Myxine.Handlers+  ( Handlers+  , onEvent+  , handle+  , handledEvents+  , focusHandlers+  , TargetFact+  , tagIs+  , attrIs+  , window+  , Propagation(..)+  ) where+ import Data.Maybe-import Data.Dependent.Map (DMap, Some)+import qualified Data.Text as Text+import Data.Text (Text)+import Data.Dependent.Map (DMap) import qualified Data.Dependent.Map as DMap+import Control.Lens+import Control.Monad.State  import Myxine.Event+import Myxine.Direct import Myxine.Target+import Myxine.ConjMap (ConjMap)+import qualified Myxine.ConjMap as ConjMap  -- | 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@.+-- The provided callback will be given the properties @props@ of this particular+-- event, and the current @model@ of a page. It has the option to do arbitrary+-- 'IO', and to return a possibly-changed @model@. It also must specify whether+-- or not the event should continue to propagate outwards to other handlers, by+-- giving a 'Propagation' (either 'Bubble' or 'Stop'). --+-- The callback will only be invoked when an event occurs which matches the+-- conjunction of the specified list of 'TargetFact's. For instance, to+-- constrain a handler to only events on @<div>@ elements with @class="foo"@, we+-- would use the 'TargetFact' @[tagIs "div", "class" `attrIs` "foo"]@.+-- -- 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:+-- 'EventType MouseEvent', your event handler as created by 'Myxine.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)+-- 'onEvent' 'Click'+--    ['tagIs' "div", "class" \`'attrIs'\` "foo"]+--    (\\properties@'MouseEvent'{} model ->+--       do print properties+--          print model+--          pure (Bubble, 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 #-}+onEvent ::+  EventType props ->+  [TargetFact] ->+  (props -> model -> IO (Propagation, model)) ->+  Handlers model+onEvent event eventFacts h =+  Handlers . DMap.singleton event . PerEventHandlers $+    ConjMap.insert eventFacts h mempty+{-# INLINE onEvent #-} +-- | A 'TargetFact' specifying that the target must have the HTML tag given;+-- otherwise, this handler will not fire.+tagIs :: Text -> TargetFact+tagIs t = HasTag (Text.toLower t)++-- | A 'TargetFact' specifying that the target must have the HTML attribute+-- given, with the exact value specified; otherwise, this handler will not fire.+attrIs :: Text -> Text -> TargetFact+attrIs a v = AttributeEquals a v++-- | A 'TargetFact' specifying that the target must be the root DOM element,+-- that is, the @window@ object.+window :: TargetFact+window = Window+ -- | 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+-- 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. If any event handler in the chain returns 'Stop', then+-- propagation stops at the current 'Target' for that handler.+handle :: Handlers model -> PageEvent -> model -> IO model+handle (Handlers allHandlers) PageEvent{event, properties, targets} model =+  let PerEventHandlers targetMap =+        fromMaybe mempty (DMap.lookup event allHandlers)+      facts = map targetFacts targets ++ [[Window]]+      handlers = map (flip ConjMap.lookup targetMap) facts+  in processHandlers handlers model+  where+    processHandlers [                  ] m = pure m+    processHandlers ([      ] : parents) m = processHandlers parents m+    processHandlers ((h : hs) : parents) m =+      do (propagation, m') <- h properties m+         case propagation of+           Bubble -> processHandlers (hs : parents) m'+           Stop   -> processHandlers (hs : [     ]) m' {-# INLINE handle #-} +-- | Extend a set of 'Handlers' that manipulate some smaller @model'@ to+-- manipulate some larger @model@, using a 'Traversal'' between the two model+-- types. Whenever a handler is invoked, it will be called with each extant+-- target of the specified 'Traversal''.+focusHandlers ::+  forall model model'. Traversal' model model' -> Handlers model' -> Handlers model+focusHandlers l (Handlers m) = Handlers $+  DMap.map (\(PerEventHandlers cm) -> PerEventHandlers (fmap zoomOut cm)) m+  where+    zoomOut ::+      (props -> model' -> IO (Propagation, model')) ->+      (props -> model -> IO (Propagation, model))+    zoomOut h props model = do+      (finalModel, finalPropagation) <-+        flip runStateT mempty $+          forOf l model \model' -> do+            (propagation, finalModel') <- liftIO (h props model')+            modify (propagation <>)+            pure finalModel'+      pure (finalPropagation, finalModel)+ -- | 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.+-- 'onEvent', and combine 'Handlers' together using their 'Monoid' instance. newtype Handlers model-  = Handlers (DMap EventType (Handler model))+  = Handlers (DMap EventType (PerEventHandlers model))  instance Semigroup (Handlers model) where   Handlers hs <> Handlers hs' =@@ -65,13 +163,23 @@ 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)+-- | Indicator for whether an event should continue to be triggered on parent+-- elements in the path. An event handler can signal that it wishes the event to+-- stop propagating by returning 'Stop'.+data Propagation+  = Bubble  -- ^ Continue to trigger the event on parent elements+  | Stop    -- ^ Continue to trigger the event for all handlers of this element,+            -- but stop before triggering it on any parent elements+  deriving (Eq, Ord, Show, Enum, Bounded) -instance Semigroup (Handler model props) where-  Handler h <> Handler g =-    Handler (\props p a -> h props p a >>= g props p)+instance Semigroup Propagation where+  l <> r | l > r = l+         | otherwise = r -instance Monoid (Handler model props) where-  mempty = Handler (\_ _ a -> pure a)+instance Monoid Propagation where+  mempty = Bubble++-- | A handler for a single event type with associated data @props@.+newtype PerEventHandlers model props+  = PerEventHandlers (ConjMap TargetFact (props -> model -> IO (Propagation, model)))+  deriving newtype (Semigroup, Monoid)

@@ -0,0 +1,10 @@+{-# language StrictData #-}+{-# options_ghc -Wno-name-shadowing -Wno-unused-matches #-}+{-# options_haddock not-home #-}++module Myxine.Internal.Event where++import Data.FileEmbed+import Myxine.Internal.TH++mkEventsAndInterfaces $(embedFile "enabled-events.json")

@@ -1,92 +0,0 @@-{-| * 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

@@ -14,10 +14,11 @@ 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.Some.Newtype    (Some(..)) import           Data.Either import           Data.Foldable import           Data.GADT.Compare+import           Data.GADT.Show import           Data.HashMap.Lazy    (HashMap) import qualified Data.HashMap.Lazy    as HashMap import           Data.HashSet         (HashSet)@@ -27,12 +28,14 @@ import           Data.Ord import           Data.Text            (Text) import           Data.Traversable+import           Data.Constraint+import           Data.Type.Equality import qualified GHC.Generics         as Generic import           Language.Haskell.TH  eventTypeName, decodeEventPropertiesName, decodeSomeEventTypeName, encodeEventTypeName :: Name eventTypeName             = mkName "EventType"-decodeEventPropertiesName = mkName "decodeEventProperties"+decodeEventPropertiesName = mkName "eventPropertiesDict" decodeSomeEventTypeName   = mkName "decodeSomeEventType" encodeEventTypeName       = mkName "encodeEventType" @@ -144,6 +147,8 @@   showInstance <- deriveEvent [t|Show|]   geqInstance           <- mkEnumGEqInstance eventTypeName (map snd cons)   gcompareInstance      <- mkEnumGCompareInstance eventTypeName (map snd cons)+  gshowInstance <-+    [d|instance GShow $(conT eventTypeName) where gshowsPrec = showsPrec|]   encodeEventType       <- mkEncodeEventType cons   decodeSomeEventType   <- mkDecodeSomeEventType cons   decodeEventProperties <- mkDecodeEventProperties (map snd cons)@@ -154,7 +159,7 @@          , showInstance          , geqInstance          , gcompareInstance-         ]+         ] <> gshowInstance   where     deriveEvent typeclass =       standaloneDerivD (pure []) [t|forall d. $typeclass ($(pure (ConT eventTypeName)) d)|]@@ -267,8 +272,8 @@ 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|]+        match (conP con []) (normalB [|Dict|]) []+  sig <- sigD decodeEventPropertiesName [t| forall d. $event d -> Dict (JSON.FromJSON d, Show d)|]   arg <- newName "event"   dec <- funD decodeEventPropertiesName            [clause [varP arg] (normalB (caseE (varE arg) cases)) []]@@ -281,10 +286,10 @@   let list =         [ [|($(litE (stringL string)), Some $(conE con))|]         | (string, GadtC [con] _ _) <- cons ]-  allEventsSig <- sigD allEvents [t|HashMap ByteString (Some $(conT eventTypeName))|]+  allEventsSig <- sigD allEvents [t|HashMap Text (Some $(conT eventTypeName))|]   allEventsDec <- funD allEvents [clause [] (normalB [|HashMap.fromList $(listE list)|]) []]   sig <- sigD decodeSomeEventTypeName-    [t| ByteString -> Maybe (Some $(conT eventTypeName))|]+    [t|Text -> Maybe (Some $(conT eventTypeName))|]   dec <- funD decodeSomeEventTypeName     [clause [] (normalB [|flip HashMap.lookup $(varE allEvents)|])       [pure allEventsSig, pure allEventsDec]]

@@ -3,61 +3,75 @@ 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:+{-| +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':+ @-type Model = ...+'Myxine.Page.runPage' ::+  'Direct.PageLocation' ->+  model ->+  ('Myxine.WithinPage' => model -> ('Direct.PageContent', 'Handlers' model)) ->+  IO ('Myxine.Page.Page' model)+@ -do page <- 'runPage' location initialModel handlers draw-  ...-  finalModel <- 'waitPage' page-  ...+The beginning of a typical @myxine-client@ app looks something like:++@+data Model = ...  -- the model that defines the page's current state++do page <- 'runPage' location (pure initialModel) ('reactive' . component)+   finalModel <- 'waitPage' page where   location :: 'PageLocation'-  location     = 'pagePort' ... <> 'pagePath' ...  -- where to connect to the server+  location = 'pagePort' 1123 <> 'pagePath' \'/\'  -- where to connect to the server    initialModel :: Model-  initialModel = ...  -- model--  handlers :: 'Handlers'-  handlers     = ...  -- controller+  initialModel = ...  -- the initial state of the model -  draw :: Model -> 'PageContent'-  draw         = ...  -- view+  component :: 'WithinPage' => 'Reactive' Model+  component = ...  -- how to render the model and listen for events that would update it @ -      To describe the interactive behavior of the page, we need to define:+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).+* __@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.+* __@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).+* __@component@:__ an interleaved description in the 'Reactive' monad explaining+both how to render the current state of the model as HTML, and how to handle+events that occur within that selfsame HTML by updating the model and performing+IO. -      * @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).-  -}+See also the sections on [building reactive pages](#Building) and [manipulating+pages](#Manipulating).+-}+-- ** #NoReactive# Using 'Page' without 'Reactive'+{-|+Although the 'Reactive' abstraction is typically the most convenient way to+build a 'Page', the 'runPage' abstraction is not bound to a specific way of+formatting HTML 'Direct.PageContent' or gathering a set of 'Handlers'. Instead,+as noted above, 'runPage' takes as input any function of type+@'Myxine.WithinPage' => model -> ('Direct.PageContent', 'Handlers' model)@. We+provide the 'Reactive'-built pages to 'runPage' by /evaluating/ them using:++@+'reactive' :: 'Reactive' model -> model -> ('Direct.PageContent', 'Handlers' model)+@++This might not always suit your desires, though, and that's precisely why it's+not baked in. You are free to construct 'PageContent' using 'pageTitle' and+'pageBody', and to construct 'Handlers' using 'Myxine.Handlers.onEvent' and+'<>', avoiding the 'Reactive' abstraction altogether if you so choose.+-}+  -- * #Pages# Creating and Waiting For Pages   Page, runPage, waitPage, stopPage    -- * #Locations# Specifying Page Locations@@ -70,21 +84,124 @@   -}   , 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.+  -- * #Building# Building Reactive Pages+  {-| When using the 'Reactive' DSL for building pages, it's intended that you+      import it alongside the 'Text.Blaze.Html5' and+      'Text.Blaze.Html5.Attributes' modules from the+      [blaze-html](https://hackage.haskell.org/package/blaze-html), which+      provide the HTML combinators required for building markup. -      '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.+      While nothing about this module hard-codes the use of+      [lenses](https://hackage.haskell.org/package/lens), it is often useful in+      the body of handlers given to 'on' to manipulate the model state using+      lens combinators, in particular the stateful 'Control.Lens.Setter..=' and+      friends. This library is designed to play well with the following import+      structure:++@+import Text.Blaze.Html5 ((!))+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as A++import Control.Monad.IO.Class+import Control.Monad.State+import Control.Monad.Reader++import Control.Lens++import Myxine+@++      __A small example:__++      Here's a simple 'Reactive' page that uses some of the combinators in this+      library, as well as the Lens combinators 'Control.Lens._1',+      'Control.Lens._2', 'Control.Lens.^.', 'Control.Lens..=',+      'Control.Lens.+=', and 'Control.Lens.*='.++      In this demonstration, you can see how the '@@' and 'on' functions work+      together to allow you to define event handlers scoped to specific regions+      of the page: handlers defined via 'on' receive only events from within the+      region delineated by the enclosing '@@'. As such, clicking on the+      background does not increment the counter, but clicking on the button+      does.++@+main :: IO ()+main = do+  page <- 'runPage' 'mempty' (0, False) ('reactive' component)+  print =<< 'waitPage' page++component :: Reactive (Integer, Bool)+component = do+  model <- 'ask'+  H.div ! A.style ("background: " '<>' if model 'Control.Lens.^.' 'Control.Lens._2' then "red" else "green") '@@' do+    'on' 'MouseOver' $ \\_ -> 'Control.Lens._2' 'Control.Lens..=' True+    'on' 'MouseOut'  $ \\_ -> 'Control.Lens._2' 'Control.Lens..=' False+    H.button ! A.style "margin: 20pt" '@@' do+      'on' 'Click' $ \\'MouseEvent'{shiftKey = False} -> 'Control.Lens._1' 'Control.Lens.+=' 1+      'on' 'Click' $ \\'MouseEvent'{shiftKey = True} -> 'Control.Lens._1' 'Control.Lens.*=' 2+      'markup' $ do+        H.span ! A.style "font-size: 20pt" $+          H.string (show (model 'Control.Lens.^.' 'Control.Lens._1'))+@   -}-  , Handlers, on-  , module Myxine.Target+  , module Myxine.Reactive +  -- * #Evaluating# Evaluating JavaScript+  {-| The functions 'eval' and 'evalBlock' evaluate some 'JavaScript' in the+      context of the current 'Page' and return a deserialized Haskell type+      (inferred from the use site), or throw a 'JsException' containing a+      human-readable string describing any error that occurred.++      For instance, here's how we would query the width of the browser window on+      every 'Resize' event:++@+windowWidth :: 'WithinPage' => 'Reactive' Int+windowWidth = do+  currentWidth <- ask+  'markup' currentWidth+  'on' 'Resize' $ \\_ -> do+    width <- 'eval' "window.innerWidth"+    'Control.Monad.State.put' width+@++      __Possible errors__ (which manifest as 'JsException's):++        * Any exception in the given JavaScript++        * 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++        * 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.++        * 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.+   -}+  , WithinPage, eval, evalBlock+   -- * #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@@ -97,7 +214,7 @@       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+      system. 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@@ -105,46 +222,21 @@       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 Control.Monad.IO.Class+import Control.Exception (SomeException, finally, throwIO, catch) import qualified Data.Aeson as JSON import Control.Concurrent+import Control.Concurrent.Async+import Data.List.NonEmpty (nonEmpty)+import Data.Text (Text)+import Data.Foldable+import qualified Unsafe.Coerce as Unsafe  import Myxine.Direct-import Myxine.Target (Target, tag, attribute)+import Myxine.Reactive import Myxine.Handlers  -- | A handle to a running 'Page'. Create this using 'runPage', and wait for its@@ -153,15 +245,28 @@ -- etc. data Page model   = Page-    { pageActions     :: !(Chan (Maybe (model -> IO model)))+    { pageActions     :: !(Chan (PageAction model))     , pageFinished    :: !(MVar (Either SomeException model))-    , pageLocation    :: !PageLocation-    , pageEventThread :: !ThreadId }+    , pageLocation    :: !PageLocation } +-- | An action to be performed in the page context. Either a call to stop the+-- page, or an effectful function to be performed on the model of the page.+data PageAction model+  = StopPage+  | PageAction !(WithinPage => model -> IO model)+ -- | 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 takes as input a 'PageLocation', an initial model, and a pure+-- function from the current state of the page's model to a rendered HTML view+-- of the page in its entirety, and the new set of 'Handlers' for page events. A+-- handler can modify the model of the page, and perform arbitrary 'IO' actions,+-- including evaluating JavaScript in the page using 'eval'. After each all+-- pertinent handlers for an event are dispatched, the page is re-rendered to+-- the browser.+-- -- 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@@ -170,52 +275,102 @@ -- __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.+--+-- Typical use of this function embeds a 'Reactive' page by using the 'reactive'+-- function to adapt it as the last argument (but this is not the only way to+-- use it, see [Using Page without Reactive](#NoReactive)):+--+-- @+-- 'runPage' location (pure initialModel) ('reactive' component)+-- @ 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) -} ->+    {- ^ The location of the 'Page' (built using 'pagePort' and/or 'pagePath'). -} ->+  (WithinPage => IO model)+    {- ^ An IO action to return the initial @model@ for the 'Page'.+         Note that this is in a 'WithinPage' context and therefore can use+         'eval' and 'evalBlock'. -} ->+  (WithinPage => model -> (PageContent, Handlers model))+    {- ^ A function to draw the @model@ as some rendered 'Direct.PageContent'+         and produce the set of 'Handlers' for events on that new view of the+         page. Note that this is in a 'WithinPage' context and therefore can use+         'eval' and 'evalBlock'.+    -} ->   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+runPage pageLocation getInitialModel drawAndHandle =+  do pageActions   :: Chan (PageAction model)           <- newChan+     currentUpdate :: Chan (Either PageEvent model)     <- newChan+     frames        :: Chan PageContent                  <- newChan+     eventLists    :: Chan (Maybe EventList)            <- newChan+     pageFinished  :: MVar (Either SomeException model) <- newEmptyMVar+     let inPage :: (WithinPage => a) -> a+         inPage = withPageContext (WithinPageContext pageLocation) -     -- 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+     -- The stream of events from the page+     nextEvent <- events pageLocation -     -- 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+     -- Renders the page:+     renderThread <- forkIO $+       forever (update pageLocation . Dynamic =<< readChan frames) -     pure (Page { pageActions, pageLocation, pageFinished, pageEventThread })+     -- Polls for the next event:+     pollThread <- forkIO $+       onLatest (writeChan currentUpdate . Left) $+         maybe (forever (threadDelay maxBound)) nextEvent <$>+           readChan eventLists +     -- Handles events and sends update actions to the model thread:+     updateThread <- forkIO $+       let loop handlers = do+             writeChan eventLists $+               SomeEvents <$> nonEmpty (handledEvents handlers)+             readChan currentUpdate >>= \case+               Left event -> do+                 writeChan pageActions (PageAction (handle handlers event))+                 loop handlers+               Right model ->+                 do let (content, handlers') = inPage (drawAndHandle model)+                    writeChan frames content+                    loop handlers'+       in catch @SomeException (loop mempty)+            (putMVar pageFinished . Left)++     -- Processes update actions to the model and sends to update thread:+     _modelThread <- forkIO $+       let loop model =+             readChan pageActions >>= \case+               StopPage -> putMVar pageFinished (Right model)+               PageAction action ->+                 do model' <- inPage (action model)+                    writeChan currentUpdate (Right model')+                    loop model'+       in finally+            (catch @SomeException+              (loop =<< inPage getInitialModel)+              (putMVar pageFinished . Left))+            (traverse_ killThread [renderThread, pollThread, updateThread])++     -- Kick off the cycle by "updating" the intial model+     writeChan pageActions (PageAction pure)++     pure Page{..}++-- | Race each action in a "stream" of actions against the arrival of the next+-- action, feeding the completed results into a function, but canceling actions+-- that take longer to produce a value than it takes to get the next action. In+-- other words, a sequential pre-emptible work queue.+onLatest :: (a -> IO ()) -> IO (IO a) -> IO ()+onLatest action rest = go =<< rest   where-    redraw :: model -> IO model-    redraw model =-      do let pageContent = draw model-         sendUpdate pageLocation (Dynamic pageContent)-         pure model+    go first =+      race first rest >>= \case+        Left a -> do+          action a+          next <- rest+          go next+        Right preempt -> do+          go preempt  -- | Wait for a 'Page' to finish executing and return its resultant @model@, or -- re-throw any exception the page encountered.@@ -225,9 +380,8 @@ -- that was raised by user code running within an event handler or -- model-modifying action. waitPage :: Page model -> IO model-waitPage Page{pageFinished, pageEventThread} =+waitPage Page{pageFinished} =   do result <- readMVar pageFinished-     killThread pageEventThread      either throwIO pure result  -- | Politely request a 'Page' to shut down. This is non-blocking: to get the@@ -236,47 +390,41 @@ -- 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+stopPage Page{pageActions, pageFinished} = do+  running <- isEmptyMVar pageFinished+  when running $ writeChan pageActions StopPage  -- | 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.+-- This function is non-blocking; the page view may not yet have been updated by+-- the time it returns. modifyPage :: Page model -> (model -> model) -> IO ()-modifyPage page f = modifyPageIO page (pure . f)+modifyPage page f = do+  running <- isEmptyMVar (pageFinished page)+  when running $ 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'.+-- the 'IO' monad, then re-draw the page to the browser. The functions 'eval'+-- and 'evalBlock' are available for evaluating JavaScript within the context of+-- the current page. ----- 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 ()+-- This function is non-blocking; the page view may not yet have been updated by+-- the time it returns.+modifyPageIO :: Page model -> (WithinPage => model -> IO model) -> IO () modifyPageIO Page{pageActions} action =-  writeChan pageActions (Just action)+  writeChan pageActions (PageAction 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.+-- This function is non-blocking; the page view may not yet have been updated by+-- the time it returns. 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: --@@ -302,66 +450,60 @@        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.+-- Borrowing a technique from Data.Reflection:++-- | The @WithinPage@ constraint, when it is present, enables the use of the+-- 'eval' and 'evalBlock' functions. Only in the body of a call to 'runPage' or+-- 'modifyPageIO' is there a canonical current page, and it's a type error to+-- use these functions anywhere else.+class WithinPage where+  -- Acquire the JavaScript evaluation context from the ambient page. This+  -- function cannot be called directly; use 'eval' or 'evalBlock' to evaluate+  -- JavaScript within a page.+  withinPageContext :: WithinPageContext++-- Specialized version of Data.Reflection.Gift:+newtype WithinPageGift r = WithinPageGift (WithinPage => r)++-- Specialized version of Data.Reflection.give:+withPageContext :: forall r. WithinPageContext -> (WithinPage => r) -> r+withPageContext c k = Unsafe.unsafeCoerce (WithinPageGift k :: WithinPageGift r) c+{-# NOINLINE withPageContext #-}++-- A "handle" that closes over the page location+newtype WithinPageContext =+  WithinPageContext PageLocation++eval, evalBlock :: (WithinPage, JSON.FromJSON a, MonadIO m) => Text -> m a+-- | Evaluate a JavaScript __expression__ in the context of the current page.+-- The given text is automatically wrapped in a @return@ statement before being+-- evaluated in the browser. -----   Keep in mind that this feature has sharp edges, and is usually---   unnecessary. In particular:+-- If you try to call 'eval' outside of a call to 'runPage' or 'modifyPageIO',+--  you'll get a type error like the following: -----   * You're evaluating an arbitrary string as JavaScript, which means there---   are no guarantees about type safety or purity.+-- > • No instance for WithinPage arising from a use of ‘eval’+-- > • In a stmt of a 'do' block: x <- eval @Int "1 + 1" -----   * 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.+-- This means that you called it in some non-'Page' context, like in the+-- main function of your program.+eval expression =+  let WithinPageContext location = withinPageContext+  in liftIO (evaluateJs location (JsExpression expression))+  +-- | Evaluate a JavaScript __block__ in the context of the current page. Unlike+-- 'eval', the given text is /not/ automatically wrapped in a @return@+-- statement, which means that you can evaluate multi-line statements, but you+-- must provide your own @return@. -----   * Any modifications you make to the DOM will be immediately overwritten on---   the next re-draw of the page. Don't do this.+-- If you try to call 'evalBlock' outside of a call to 'runPage' or+--  'modifyPageIO', you'll get a type error like the following: -----   * 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.+-- > • No instance for WithinPage arising from a use of ‘evalBlock’+-- > • In a stmt of a 'do' block: x <- evalBlock @Int "return 1;" ----- 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+-- This means that you called it in some non-'Page' context, like in the+-- main function of your program.+evalBlock block =+  let WithinPageContext location = withinPageContext+  in liftIO (evaluateJs location (JsBlock block))

@@ -0,0 +1,315 @@+module Myxine.Reactive+  ( Reactive, ReactiveM, reactive, title, markup,+    on', on, Propagation(..), (@@), (##), target, this+  ) where++import Text.Blaze.Html5 (Html, ToMarkup(..), string, (!), dataAttribute)+import Text.Blaze.Renderer.Text+import Text.Blaze.Internal (Attributable)++import Data.String+import Data.List (intercalate)+import Control.Monad.State+import Control.Monad.Reader+import Data.Monoid+import Data.Text (Text)+import Data.List.NonEmpty (NonEmpty(..), (<|))+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Text.Lazy as Text+import Control.Spoon (teaspoonWithHandles)+import qualified Control.Exception as Exception+import Control.Lens hiding ((<|))++import Myxine.Event+import qualified Myxine.Direct as Direct (PageContent, pageBody, pageTitle)+import Myxine.Handlers++-- | The builder state for a reactive component.+data ReactiveBuilder model =+  ReactiveBuilder+    { location   :: !(NonEmpty Word)+    -- ^ The current location in the tree of listener scopes we've created.+    -- Calls to 'on' refer to the enclosing scope (that is, the tail of this+    -- list).+    , handlers   :: !(Handlers model)+    -- ^ The accumulated handlers for events built up so far.+    , pageMarkup :: !Html+    -- ^ The accumulated markup for the page built up so far.+    , pageTitle  :: !(Last Text)+    -- ^ The most-recently set title for the page (via 'title').+    }++-- | The underlying builder monad for the 'Reactive' type.+--+-- This is almost always used with a return type of @()@, hence you will usually+-- see it aliased as 'Reactive' @model@.+newtype ReactiveM model a =+  ReactiveM (ReaderT model (State (ReactiveBuilder model)) a)+  deriving newtype (Functor, Applicative, Monad, MonadReader model)++-- | The 'Reactive' type interleaves the description of page markup with the+-- specification of event handlers for the page.+--+-- It is a 'Monoid' and its underlying type 'ReactiveM' is a 'Monad', which+-- means that just like the Blaze templating library, it can be (and is designed+-- to be!) used in @do@-notation. Importantly, it is also a 'MonadReader'+-- @model@, where the current model is returned by 'ask'.+type Reactive model = ReactiveM model ()++-- | Wrap an inner reactive component in some enclosing HTML. Any listeners+-- created via 'on' in the wrapped component will be scoped to only events that+-- occur within this chunk of HTML.+--+-- In the following example, we install a 'Click' handler for the whole page,+-- then build a @<div>@ with /another/ 'Click' handler inside that page, which+-- returns 'Stop' from 'on'' to stop the 'Click' event from bubbling out to the+-- outer handler when the inner @<div>@ is clicked.+--+-- @+-- do 'on' 'Click' $ \\_ ->+--      liftIO $ putStrLn "Clicked outside!"+--    div ! style "background: lightblue;" '@@' do+--      "Click here, or elsewhere..."+--      'on'' 'Click' $ \\_ -> do+--        liftIO $ putStrLn "Clicked inside!"+--        pure 'Stop'+-- @+(@@) :: (Html -> Html) -> ReactiveM model a -> ReactiveM model a+wrap @@ ReactiveM inner = ReactiveM do+  builder <- get+  model <- ask+  let originalLoc = location builder+      (result, builder') =+        runState+          (runReaderT inner model)+          builder+            { location = 0 <| originalLoc  -- descend a level in location cursor+            , pageMarkup = mempty+            -- handlers & pageTitle are threaded through and preserved+            }+  put builder'+    { location = let (h :| t) = originalLoc in (h + 1 :| t)  -- move sideways+    , pageMarkup =+      do pageMarkup builder+         wrapInTarget originalLoc $ wrap (pageMarkup builder')+    -- handlers & pageTitle are threaded through and preserved+    }+  pure result+  where+    wrapInTarget :: NonEmpty Word -> Html -> Html+    wrapInTarget loc = (! dataAttribute clientDataAttr (showLoc loc))+infixr 5 @@++-- | Create a scope for event listeners without wrapping any enclosing HTML. Any+-- listeners created via 'on' will apply only to HTML that is written inside+-- this block, rather than to the enclosing broader scope.+--+-- >>> target === (id @@)+target :: ReactiveM model a -> ReactiveM model a+target = (id @@)++-- | Return a piece of JavaScript code which looks up the object corresponding+-- to the current scope's location in the page. This is suitable to be used in+-- 'eval', for instance, to retrieve properties of a particular element.+--+-- If there is no enclosing '@@', then this is the @window@ object; otherwise,+-- it is the outermost HTML element object created by the first argument to the+-- enclosing '@@'. If there are multiple elements at the root of the enclosing+-- '@@', then the first of these is selected.+--+-- For example, here's an input which reports its own contents:+--+-- @+-- textbox :: Reactive Text+-- textbox = input @@ do+--   e <- this+--   on Input \_ -> do+--     value <- eval $ this <> ".value"+--     put value+-- @+this :: ReactiveM model Text+this = ReactiveM do+  loc <- gets (NonEmpty.tail . location)+  pure case loc of+    [] -> "window"+    h : t ->+      let selector = "[data-" <> clientDataAttr <> "=\"" <> showLoc (h :| t) <> "\"]"+      in "(document.querySelector('" <> selector <> "'))"++-- | Write an atomic piece of HTML (or anything that can be converted to it) to+-- the page in this location. Event listeners for its enclosing scope can be+-- added by sequential use of 'on'. If you need sub-pieces of this HTML to have+-- their own scoped event listeners, use '@@' to build a composite component.+--+-- >>> markup h === const (toMarkup h) @@ pure ()+markup :: ToMarkup h => h -> Reactive model+markup h = const (toMarkup h) @@ pure ()++-- | Set the title for the page. If this function is called multiple times in+-- one update, the most recent call is used.+title :: Text -> Reactive model+title t = ReactiveM (modify \wb -> wb { pageTitle = Last (Just t) })++-- | Listen to a particular event and react to it by modifying the model for the+-- page. This function's returned 'Propagation' value specifies whether or not+-- to propagate the event outwards to other enclosing contexts. The event target+-- is scoped to the enclosing '@@', or the whole page if at the top level.+--+-- When the specified 'EventType' occurs, the event handler will be called with+-- that event type's corresponding property record, e.g. a 'Click' event's+-- handler will receive a 'MouseEvent' record. A handler can modify the page's+-- model via 'State'ful actions and perform arbitrary IO using 'liftIO'. In the+-- context of a running page, a handler also has access to the 'eval' and+-- 'evalBlock' functions to evaluate JavaScript in that page.+--+-- __Exception behavior:__ This function catches @PatternMatchFail@ exceptions+-- thrown by the passed function. That is, if there is a partial pattern match+-- in the pure function from event properties to stateful update, the stateful+-- update will be silently skipped. This is useful as a shorthand to select only+-- events of a certain sort, for instance:+--+-- @+-- 'on'' 'Click' \\'MouseEvent'{shiftKey = True} ->+--   do putStrLn "Shift + Click!"+--      pure 'Bubble'+-- @+on' ::+  EventType props ->+  (props -> StateT model IO Propagation) ->+  Reactive model+on' event reaction = ReactiveM do+  loc <- gets (NonEmpty.tail . location)+  let selector =+        case loc of+          [] -> window+          (h : t) -> ("data-" <> clientDataAttr) `attrIs`+            Text.toStrict (Text.pack (showLoc (h :| t)))+  modify \builder ->+    builder { handlers = mappend (handlers builder) $+              onEvent event [selector] $+              \props model ->+                -- We need to do a pure and impure catch, because GHC might+                -- decide to inline things inside the IO action, or it might+                -- not! So we check in both circumstances.+                case tryMatch (runStateT (reaction props) model) of+                  Nothing -> pure (Bubble, model)+                  Just io ->+                    do result <- Exception.try @Exception.PatternMatchFail io+                       case result of+                         Left _ -> pure (Bubble, model)+                         Right update -> pure update }+  where+    tryMatch = teaspoonWithHandles+      [Exception.Handler \(_ :: Exception.PatternMatchFail) -> pure Nothing]++-- | Listen to a particular event and react to it by modifying the model for the+-- page. This is a special case of 'on'' where the event is always allowed to+-- bubble out to listeners in enclosing contexts.+--+-- See the documentation for 'on''.+on ::+  EventType props ->+  (props -> StateT model IO ()) ->+  Reactive model+on event action = on' event (\props -> action props >> pure Bubble)++-- | Focus a reactive page fragment to manipulate a piece of a larger model,+-- using a 'Traversal'' to specify what part(s) of the larger model to+-- manipulate.+--+-- This is especially useful when creating generic components which can be+-- re-used in the context of many different models. For instance, we can define+-- a toggle button and specify separately which part of a model it toggles:+--+-- @+-- toggle :: 'Reactive' Bool+-- toggle =+--   button '@@' do+--     active <- 'ask'+--     if active then \"ON\" else \"OFF\"+--     'on' 'Click' \\_ -> 'modify' not+--+-- twoToggles :: 'Reactive' (Bool, Bool)+-- twoToggles = do+--   _1 '##' toggle+--   _2 '##' toggle+-- @+--+-- This function takes a 'Traversal'', which is strictly more general than a+-- 'Lens''. This means you can use traversals with zero or more than one target,+-- and this many replicas of the given 'Reactive' fragment will be generated,+-- each separately controlling its corresponding portion of the model. This+-- means the above example could also be phrased:+--+-- @+-- twoToggles :: 'Reactive' (Bool, Bool)+-- twoToggles = 'each' '##' toggle+-- @+(##) :: Traversal' model model' -> Reactive model' -> Reactive model+l ## ReactiveM action =+  ReactiveM $+    ReaderT \model ->+      iforOf_ (indexing l) model \i model' ->+        StateT \b@ReactiveBuilder{handlers = priorHandlers} ->+          let b' = flip execState (b {handlers = mempty}) $+                runReaderT action model'+          in Identity $+            ((), b' { handlers =+                      priorHandlers <>+                      focusHandlers (indexing l . index i) (handlers b')+                    })+-- TODO: make this more efficient using a pre-applied Traversal?+infixr 5 ##++-- | Evaluate a reactive component to produce a pair of 'Direct.PageContent' and+-- 'Handlers'. This is the bridge between the 'Direct.runPage' abstraction and+-- the 'Reactive' abstraction: use this to run a reactive component in a+-- 'Myxine.Page'.+reactive :: Reactive model -> model -> (Direct.PageContent, Handlers model)+reactive (ReactiveM action) model =+  let ReactiveBuilder{handlers, pageMarkup, pageTitle = pageContentTitle} =+        execState (runReaderT action model) initialBuilder+      pageContentBody = renderMarkup pageMarkup+  in (Direct.pageBody (Text.toStrict pageContentBody)+      <> foldMap Direct.pageTitle pageContentTitle,+      handlers)+  where+    initialBuilder = ReactiveBuilder+      { location = (0 :| [])+      , handlers = mempty+      , pageMarkup = pure ()+      , pageTitle = Last Nothing }++-- | 'Reactive' pages can be combined using '<>', which concatenates their HTML+-- content and merges their sets of 'Handlers'.+instance Semigroup a => Semigroup (ReactiveM model a) where+  m <> n = (<>) <$> m <*> n++-- | The empty 'Reactive' page, with no handlers and no content, is 'mempty'.+instance Monoid a => Monoid (ReactiveM model a) where mempty = pure mempty++-- | You can apply an HTML attribute to any 'Reactive' page using '!'.+instance Attributable (ReactiveM model a) where+  w ! a = (! a) @@ w++-- | You can apply an HTML attribute to any function between 'Reactive' pages+-- using '!'. This is useful when building re-usable widget libraries, allowing+-- their attributes to be modified after the fact but before they are filled+-- with contents.+instance Attributable (ReactiveM model a -> ReactiveM model a) where+  f ! a = (! a) . f++-- | A string literal is a 'Reactive' page containing that selfsame text.+instance (a ~ ()) => IsString (ReactiveM model a) where+  fromString = markup . string++-- | The in-browser name for the data attribute holding our tracking id. This is+-- not the same as the @id@ attribute, because this means the user is free to+-- use the _real_ @id@ attribute as they please.+clientDataAttr :: IsString a => a+clientDataAttr = "myxine-client-widget-id"++-- | Helper function to show a location in the page: add hyphens between every+-- number.+showLoc :: IsString a => (NonEmpty Word) -> a+showLoc = fromString . intercalate "-" . map show . NonEmpty.toList

@@ -1,7 +1,8 @@ {-# options_haddock not-home #-} -module Myxine.Target (Target, attribute, tag) where+module Myxine.Target (Target, attribute, tag, TargetFact(..), targetFacts) where +import Data.Hashable import Data.Text (Text) import qualified Data.Aeson as JSON import Data.HashMap.Lazy (HashMap)@@ -30,3 +31,18 @@ tag :: Target -> Text tag Target{tagName} = tagName {-# INLINE tag #-}++-- | A fact about a 'Target', such as it having a particular tag or having a+-- particular attribute equal to a particular value.+--+-- You can construct a 'TargetFact' using 'Myxine.tagIs', 'Myxine.attrIs', or+-- 'Myxine.window'.+data TargetFact+  = HasTag !Text+  | AttributeEquals !Text !Text+  | Window+  deriving (Eq, Ord, Show, Generic, Hashable)++targetFacts :: Target -> [TargetFact]+targetFacts Target{tagName, attributes} =+  HasTag tagName : map (uncurry AttributeEquals) (HashMap.toList attributes)