suavemente (empty) → 0.1.0.0
raw patch · 7 files changed
+501/−0 lines, 7 filesdep +basedep +blaze-markupdep +bytestringsetup-changed
Dependencies added: base, blaze-markup, bytestring, diagrams-core, diagrams-lib, diagrams-svg, interpolatedstring-perl6, lens, mtl, servant, servant-blaze, servant-server, servant-websockets, stm, streaming, suavemente, svg-builder, transformers, warp, websockets
Files
- ChangeLog.md +7/−0
- LICENSE +30/−0
- README.md +61/−0
- Setup.hs +2/−0
- app/Main.hs +25/−0
- src/Web/Suavemente.hs +290/−0
- suavemente.cabal +86/−0
+ ChangeLog.md view
@@ -0,0 +1,7 @@+# Changelog for suavemente++## 0.1.0.0 -- 2019-01-04++First release!++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2019++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,61 @@+# suavemente++[](https://travis-ci.org/isovector/suavemente) | [Hackage][hackage]++[hackage]: https://hackage.haskell.org/package/suavemente++## Dedication++> Today's kitchen is all about a well-planned space that makes cooking a+> completely interactive experience among family and friends.+>+> Candice Olson+++## Overview++Suavemente is an applicative functor capable of seamlessly talking to HTML+elements. Running a suavemente program automatically spins up a webserver and+hooks up its pages with websockets. The use case is to quickly deploy simple,+interactive Haskell programs without needing to figure out how the fuck GHCJS+works.+++## Example++```haskell+{-# LANGUAGE ApplicativeDo #-}++module Main where++import Diagrams.Backend.SVG+import Diagrams.Prelude hiding (rad)+import Web.Suavemente+++main :: IO ()+main = suavemente $ do+ rad <- slider "Radius" 1 10 5+ r <- realSlider "Red" 0 1 0.05 1+ g <- realSlider "Green" 0 1 0.05 1+ b <- realSlider "Blue" 0 1 0.05 1+ x <- slider "X" 0 20 10+ y <- slider "Y" 0 20 10++ pure (+ circle rad+ # fc (sRGB r g b)+ # translate (r2 (x, y))+ # rectEnvelope (p2 (0, 0)) (r2 (20, 20))+ :: Diagram B)+```+++## To Do++The "protocol" is disgusting---it just tries to `read` the incoming websocket+data. A better approach would be to hook it up via `FromJSON`, but it's+nontrivial to get JSON out of a web form and I cbf.++Pull requests are welcome!+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE ApplicativeDo #-}++module Main where++import Diagrams.Backend.SVG+import Diagrams.Prelude hiding (rad)+import Web.Suavemente+++main :: IO ()+main = suavemente $ do+ rad <- slider "Radius" 1 10 5+ r <- realSlider "Red" 0 1 0.05 1+ g <- realSlider "Green" 0 1 0.05 1+ b <- realSlider "Blue" 0 1 0.05 1+ x <- slider "X" 0 20 10+ y <- slider "Y" 0 20 10++ pure (+ circle rad+ # fc (sRGB r g b)+ # translate (r2 (x, y))+ # rectEnvelope (p2 (0, 0)) (r2 (20, 20))+ :: Diagram B)+
+ src/Web/Suavemente.hs view
@@ -0,0 +1,290 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}++module Web.Suavemente+ ( -- * Primary Stuff+ Suave ()+ , Input ()+ , suavemente++ -- * Inputs+ , textbox+ , checkbox+ , slider+ , realSlider++ -- * Making New Inputs+ , mkInput+ , showMarkup++ -- * Reexports+ , Markup+ , ToMarkup (..)+ , qc+ , q+ ) where++import Control.Applicative (liftA2)+import Control.Concurrent.STM.TVar (TVar, newTVar, readTVar, writeTVar)+import Control.Lens hiding ((#))+import Control.Monad.IO.Class (liftIO)+import Control.Monad.STM (STM, atomically)+import Control.Monad.State (StateT (..), evalStateT)+import Control.Monad.State.Class (MonadState (..), modify)+import Control.Monad.Trans.Class (lift)+import Data.Bifunctor (second)+import Data.Bool (bool)+import qualified Data.ByteString.Char8 as B+import Data.Char (toUpper)+import Data.Data.Lens (upon)+import Data.Proxy (Proxy (..))+import Diagrams.Backend.SVG (B, SVG (..), Options (..))+import qualified Diagrams.Prelude as D+import Graphics.Svg.Core (renderBS)+import Network.Wai.Handler.Warp (run)+import Network.WebSockets (Connection, receiveData, sendTextData)+import Servant (Get, Handler, (:<|>)(..), (:>), serve)+import Servant.API.WebSocket (WebSocket)+import Servant.HTML.Blaze (HTML)+import qualified Streaming as S+import qualified Streaming.Prelude as S+import Text.Blaze (preEscapedString, Markup, ToMarkup (..), unsafeLazyByteString )+import Text.Blaze.Renderer.String (renderMarkup)+import Text.InterpolatedString.Perl6 (qc, q)+++------------------------------------------------------------------------------+-- | An applicative functor capable of getting input from an HTML page.+newtype Suave a = Suave+ { suavely :: StateT Int STM (Input a)+ } deriving Functor++instance Applicative Suave where+ pure = Suave . pure . pure+ Suave f <*> Suave a = Suave $ liftA2 (<*>) f a+++------------------------------------------------------------------------------+-- | An applicative functor can introduce new markup, and hook it up to the+-- event stream.+data Input a = Input+ { -- | The markup of the input.+ _iHtml :: Markup++ -- | A means of handling the event stream. The stream is of (name, value)+ -- pairs. An 'Input' is responsible for stripping its own events out of+ -- this stream.+ --+ -- The 'IO ()' action is to publish a change notification to the downstream+ -- computations.+ , _iFold :: IO ()+ -> S.Stream (S.Of (String, String)) IO ()+ -> S.Stream (S.Of (String, String)) IO ()++ -- | The current value of the 'Input'.+ , _iValue :: STM a+ } deriving Functor++instance Applicative Input where+ pure = Input mempty (const . const $ pure ()) . pure+ Input fh ff fv <*> Input ah af av =+ Input (fh <> ah)+ (liftA2 (.) ff af)+ (fv <*> av)+++------------------------------------------------------------------------------+-- | Run a 'Suave' computation by spinning up its webpage at @localhost:8080@.+suavemente :: ToMarkup a => Suave a -> IO ()+suavemente w = do+ Input html f a <- atomically $ evalStateT (suavely w) 0+ a0 <- atomically a+ run 8080+ . serve (Proxy @API)+ $ pure (htmlPage a0 <> html) :<|> socketHandler a f+++------------------------------------------------------------------------------+-- | Constructor for building 'Suave' inputs that are backed by HTML elements.+mkInput+ :: Read a+ => (String -> a -> Markup) -- ^ Function to construct the HTML element. The first parameter is what should be used for the element's 'id' attribute.+ -> a -- ^ The input's initial value.+ -> Suave a+mkInput f a = Suave $ do+ name <- genName+ tvar <- lift $ newTVar a+ pure $ Input (f name a) (getEvents tvar name) (readTVar tvar)+++------------------------------------------------------------------------------+-- | Construct an '_iFold' field for 'Input's.+getEvents+ :: Read a+ => TVar a -- ^ The underlying 'TVar' to publish changes to.+ -> String -- ^ The name of the HTML input.+ -> IO () -- ^ Publish a change notification.+ -> S.Stream (S.Of (String, String)) IO ()+ -> S.Stream (S.Of (String, String)) IO ()+getEvents t n update+ = S.mapMaybeM (+ \a@(i, z) ->+ case i == n of+ True -> do+ liftIO . atomically . writeTVar t . read $ z & upon head %~ toUpper+ update+ pure Nothing+ False -> pure $ Just a+ )+++------------------------------------------------------------------------------+-- | Get a 'String' representation of a markup-able type. Useful for+-- constructing elements via quasiquotation.+showMarkup :: ToMarkup a => a -> String+showMarkup = renderMarkup . toMarkup+++------------------------------------------------------------------------------+-- | Create an input driven by an HTML slider.+slider+ :: (ToMarkup a, Num a, Read a)+ => String -- ^ label+ -> a -- ^ min+ -> a -- ^ max+ -> a -- ^ initial value+ -> Suave a+slider label l u = mkInput $ \name v ->+ preEscapedString+ [qc|<tr><td>+ <label for="{name}">{label}</label>+ </td><td>+ <input id="{name}" oninput="onChangeFunc(event)" type="range" min="{showMarkup l}" max="{showMarkup u}" value="{showMarkup v}" autocomplete="off">+ </td></tr>|]+++------------------------------------------------------------------------------+-- | Create an input driven by an HTML slider, whose domain is the real+-- numbers.+realSlider+ :: (ToMarkup a, Num a, Real a, Read a)+ => String -- ^ label+ -> a -- ^ min+ -> a -- ^ max+ -> a -- ^ step+ -> a -- ^ initial value+ -> Suave a+realSlider label l u s = mkInput $ \name v ->+ preEscapedString+ [qc|<tr><td>+ <label for="{name}">{label}</label>+ </td><td>+ <input id="{name}" oninput="onChangeFunc(event)" type="range" min="{showMarkup l}" max="{showMarkup u}" step="{showMarkup s}" value="{showMarkup v}" autocomplete="off">+ </td></tr>|]+++------------------------------------------------------------------------------+-- | Create an input driven by an HTML checkbox.+checkbox :: String -> Bool -> Suave Bool+checkbox label = mkInput $ \name v ->+ preEscapedString+ [qc|<tr><td>+ <label for="{name}">{label}</label>+ </td><td>+ <input id="{name}" oninput="onChangeBoolFunc(event)" type="checkbox" {bool ("" :: String) "checked='checked'" v} autocomplete="off">+ </td></tr>|]+++------------------------------------------------------------------------------+-- | Create an input driven by an HTML textbox.+textbox+ :: String -- ^ label+ -> String -- ^ initial value+ -> Suave String+textbox label = mkInput $ \name v ->+ preEscapedString+ [qc|<tr><td>+ <label for="{name}">{label}</label>+ </td><td>+ <input id="{name}" oninput="onChangeStrFunc(event)" type="text" value="{v}" autocomplete="off">+ </td></tr>|]+++------------------------------------------------------------------------------+-- | HTML code to inject into all 'Suave' pages.+htmlPage :: ToMarkup a => a -> Markup+htmlPage a = preEscapedString $+ [q|+ <style>+ </style>|]+ +++ [qc|+ <script>+ let ws = new WebSocket("ws://localhost:8080/suavemente");+ ws.onmessage = (e) => document.getElementById("result").innerHTML = e.data;+ let onChangeFunc = (e) => ws.send(e.target.id + " " + e.target.value)+ let onChangeStrFunc = (e) => ws.send(e.target.id + " \"" + e.target.value + "\"")+ let onChangeBoolFunc = (e) => ws.send(e.target.id + " " + e.target.checked)+ </script>+ <div id="result">{showMarkup a}</div>+ <table>+ |]+++------------------------------------------------------------------------------+-- | 'Handler' endpoint for responding to 'Suave''s websockets.+socketHandler+ :: ToMarkup a+ => STM a+ -> (IO () -> S.Stream (S.Of (String, String)) IO () -> S.Stream (S.Of (String, String)) IO ())+ -> Connection+ -> Handler ()+socketHandler v f c+ = liftIO+ . S.effects+ . f (sendTextData c . B.pack . showMarkup =<< atomically v)+ . S.mapM (liftA2 (>>) print pure)+ . S.map (second (drop 1) . span (/= ' '))+ . S.repeatM+ . fmap B.unpack+ $ receiveData c+++------------------------------------------------------------------------------+-- | Generate a new name for an HTML element.+genName :: MonadState Int m => m String+genName = do+ s <- get+ modify (+1)+ pure $ show s+++------------------------------------------------------------------------------+-- | The API for 'Suave' pages.+type API = Get '[HTML] Markup+ :<|> "suavemente" :> WebSocket+++------------------------------------------------------------------------------+-- | Orphan instance allowing us to draw 'D.Diagram's.+instance ToMarkup (D.QDiagram B D.V2 Double D.Any) where+ toMarkup = unsafeLazyByteString+ . renderBS+ . D.renderDia SVG+ (SVGOptions (D.mkWidth 250) Nothing "" [] True)+
+ suavemente.cabal view
@@ -0,0 +1,86 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: af625e3a3e5f5b67110256419c1fa138bf982ee015faf95cda8b75c3edd41ae8++name: suavemente+version: 0.1.0.0+synopsis: An applicative functor that seamlessly talks to HTML inputs.+description: Please see the README on GitHub at <https://github.com/isovector/suavemente#readme>+category: Web+homepage: https://github.com/isovector/suavemente#readme+bug-reports: https://github.com/isovector/suavemente/issues+author: Sandy Maguire+maintainer: sandy@sandymaguire.me+copyright: 2019 Sandy Maguire+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10+extra-source-files:+ ChangeLog.md+ README.md++source-repository head+ type: git+ location: https://github.com/isovector/suavemente++library+ exposed-modules:+ Web.Suavemente+ other-modules:+ Paths_suavemente+ hs-source-dirs:+ src+ build-depends:+ base >=4.7 && <5+ , blaze-markup+ , bytestring+ , diagrams-core+ , diagrams-lib+ , diagrams-svg+ , interpolatedstring-perl6+ , lens+ , mtl+ , servant+ , servant-blaze+ , servant-server+ , servant-websockets+ , stm+ , streaming+ , svg-builder+ , transformers+ , warp+ , websockets+ default-language: Haskell2010++executable suavemente-exe+ main-is: Main.hs+ other-modules:+ Paths_suavemente+ hs-source-dirs:+ app+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , blaze-markup+ , bytestring+ , diagrams-core+ , diagrams-lib+ , diagrams-svg+ , interpolatedstring-perl6+ , lens+ , mtl+ , servant+ , servant-blaze+ , servant-server+ , servant-websockets+ , stm+ , streaming+ , suavemente+ , svg-builder+ , transformers+ , warp+ , websockets+ default-language: Haskell2010