Haskell DSLs for Interactive Web Services

Andrew Farmer and Andy Gill
University of Kansas

XLDI 2012
September 9, 2012

Motivation

Can we address these issues using language technology?

Blank Canvas

DSL for manipulating an HTML canvas created for an FP class.

More information: http://ittc.ku.edu/csdl/fpg/sites/default/files/class17.pdf

Overview

Scotty

A declarative (shallow) DSL for specifying RESTful web applications.

Kansas Comet

A Scotty plugin allowing the server to push Javascript to the client for execution.

Sunroof

A monadic (deep) DSL that can be reified to Javascript code.

Shallow DSLs

Types and computation are done by the host language.

data Bit = High | Low deriving Show

xor :: Bit -> Bit -> Bit
xor High Low = High
xor Low High = High
xor _     _  = Low

and :: Bit -> Bit -> Bit
and High High = High
and _    _    = Low

halfAdder :: Bit -> Bit -> (Bit, Bit)
halfAdder x y = (carry, sum)
    where carry = and x y
          sum   = xor x y
ghci> halfAdder High Low
(Low,High)

Deep DSLs

Computation is reified as a data structure, over which we can define interpretations.

data Bit = Var String
         | Lit Bool
         | And Bit Bit
         | Xor Bit Bit

xor :: Bit -> Bit -> Bit
xor = Xor

and :: Bit -> Bit -> Bit
and = And

high :: Bit
high = Lit True

low :: Bit
low = Lit False
halfAdder :: Bit -> Bit -> (Bit, Bit)
halfAdder x y = (carry, sum)
    where carry = and x y
          sum   = xor x y

eval :: [(String,Bit)] -> Bit -> Bool
instance Show Bit where ...
ghci> halfAdder high low
"(True `and` False,True `xor` False)"
 

Scotty

A declarative DSL for RESTful web applications.

Scotty's design taken from that of the Ruby language's Sinatra.

Scotty

{-# LANGUAGE OverloadedStrings #-}

import Web.Scotty

import Data.Monoid (mconcat)

main = scotty 3000 $ do
  get "/:word" $ do
    beam <- param "word"
    html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>"]

Some types:

scotty :: Port -> ScottyM () -> IO ()

get :: RoutePattern -> ActionM () -> ScottyM ()

param :: Parsable a => Text -> ActionM a

html :: Text -> ActionM ()

See http://hackage.haskell.org/package/scotty for more!

Scotty - Typed Captures

Routes only match if the capture can be parsed at the correct type.

{-# LANGUAGE OverloadedStrings #-}

import Web.Scotty

import Data.Text.Lazy (pack)

main = scotty 3000 $ do
    get "/:x" $ do
        x <- param "x"
        text $ pack $ show $ x + (54::Int)

    get "/:word" $ do
        word <- param "word"
        text $ pack $ "you said: " ++ word

Try it out: cabal install scotty

Kansas Comet

Comet is a web design pattern allowing the server to push data to the client.

Kansas Comet:

Kansas Comet - Request/Response Cycle

Kansas Comet Request/Response Ladder Diagram

Kansas Comet - Example

Kansas Comet - Example HTML

<html>
  <head>
    <title>Kansas Comet Example</title>
    <script type="text/javascript" src="js/jquery.js"></script>
    <script type="text/javascript" src="js/jquery-json.js"></script>
    <script type="text/javascript" src="js/kansas-comet.js"></script>
    <link type="text/css" href="css/ui-lightness/jquery-ui.css" rel="Stylesheet" />
    <script type="text/javascript" src="js/jquery-ui.js"></script>
  </head>
  <body>
    <div align="center" style="border: 1px solid; padding: 10px; display: inline-block; line-height: 3em;">
      <button id="reset" class="click">Reset</button>
      <button id="down" class="click">-1</button>
      <button id="up" class="click">+1</button>
      <br/>
      <span id="fib-out" style="font-size: x-large;" class="click">fib 0 = 1</span>
      <br/>
      <div id="slider" style="width: 200px" class="slide"></div>
    </div>

    <script type="text/javascript">
      ...
    </script>
  </body>
</html>

Kansas Comet - Example Javascript

$(document).ready(function() {
    $.kc.connect("/example");

    $("button").button();

    $("#slider").slider({
        range: "min",
        value: 0,
        min: 0,
        max: 25
    });
});

Kansas Comet - Example Server

import Web.KansasComet as KC
... other imports ...

main = scotty 3000 $ do
    kcomet <- liftIO kCometPlugin

    let pol = only [ ("","index.html")
                   , ("js/kansas-comet.js",kcomet)
                   ]
              <|> ((hasPrefix "css/" <|> hasPrefix "js/") >-> addBase ".")

    middleware $ staticPolicy pol

    KC.connect opts web_app

opts :: KC.Options
opts = def { prefix = "/example", verbose = 0 }
kCometPlugin :: IO String

connect :: Options -> (Document -> IO ()) -> ScottyM ()

Kansas Comet - Application

web_app :: Document -> IO ()
web_app doc = do
    registerEvents doc "body" (slide <> click)
    forkIO $ control doc 0
    return ()

control :: Document -> Int -> IO ()
control doc model = do
    Just res <- waitForEvent doc "body" (slide <> click)
    case res of
        Slide _ n                      -> view doc n
        Click "up"    _ _ | model < 25 -> view doc (model + 1)
        Click "down"  _ _ | model > 0  -> view doc (model - 1)
        Click "reset" _ _              -> view doc 0
        _ -> control doc model

view :: Document -> Int -> IO ()
view doc n = do
    send doc $ concat
                [ "$('#slider').slider('value'," ++ show n ++ ");"
                , "$('#fib-out').html('fib " ++ show n ++ " = ...')"
                ]
    send doc ("$('#fib-out').text('fib " ++ show n ++ " = "
                                  ++ show (fib n) ++ "')")

    control doc n

fib :: Int -> Int
fib n = if n < 2 then 1 else fib (n-1) + fib (n-2)

Kansas Comet - Defining Events

data Event = Slide String Int
           | Click String Int Int
    deriving (Show)

slide = event "slide" Slide
            <&> "id"      .= "$(widget).attr('id')"
            <&> "count"   .= "aux.value"

click = event "click" Click
            <&> "id"      .= "$(widget).attr('id')"
            <&> "pageX"   .=  "event.pageX"
            <&> "pageY"   .=  "event.pageY"

Sunroof

A monadic DSL that can be reified to Javascript code.

Rather than send each event to the server, event handling code can be compiled for execution on the client-side.

Sunroof - Implementation

Consider:

do c <- getContext "my-canvas"
   c <$> beginPath()
   c <$> arc (x,y,20,0,2*pi,False)
   c <$> fillStyle := "#8ED6FF"
   c <$> fill()

How do we implement a bind-like operator for a deep DSL?

(>>=) :: Monad m => m a -> (a -> m b) -> m b

We need to invent a value of type a!

bindish :: (Monad m, Reify a) => m a -> (a -> m b) -> m b

Sunroof - Implementation

GADTs to the rescue!

{-# LANGUAGE GADTs, KindSignatures #-}
data JS :: * -> * where
    JS_Call :: (Sunroof a) => String -> JS a
    ...
    JS_Ret  ::                a      -> JS a
    JS_Bind ::                JS a   -> (a -> JS b) -> JS b

instance Monad JS where
    return = JS_Ret
    (>>=) = JS_Bind

class Sunroof a where
    mkVar :: Uniq -> a

instance Sunroof () where
    mkVar _ = ()

call :: String -> JS ()
call = JS_Call

Sunroof - Implementation

foo = do
    call "foo"
    call "bar"
    call "baz"

compile :: Sunroof a => JS a -> String
compile (JS_Call s)   = s ++ "();"
compile (JS_Ret _)    = ""
compile (JS_Bind m n) = case m of
    JS_Bind p q -> compile $ p >>= (\a -> q a >>= n)
    JS_Ret x    -> compile $ n x
    JS_Call {}  -> let x = mkVar 54 in compile m ++ " " ++ compile (n x)
ghci> compile foo
"foo(); bar(); baz();"

See also: operational package, and free monads + codensity.

Sunroof - Example

web_app :: Document -> IO ()
web_app doc = do
    registerEvents doc "body" (slide <> click)

    sync doc $ do
        obj <- new
        obj <$> "model" := (0 :: JSNumber)

        fun obj "fib" $ \ (n :: JSNumber) ->
            ifB (n <* 2)
                (return 1)
                (liftM2 (+) (fib (n - 1)) (fib (n - 2)))

        fun obj "control" $ \ () ->
            wait "body" (slide <> click) $ \ res -> do
                model <- eval (obj ! "model") :: JS JSNumber

                switchB (res ! "id" :: JSString)
                    [ ("slider", update obj "model" (res ! "value") 0 25)
                    , ("up"    , update obj "model" (model + 1)     0 25)
                    , ("down"  , update obj "model" (model - 1)     0 25)
                    , ("reset" , update obj "model" 0               0 25)
                    ] $ return ()

                view ()

        fun obj "view" $ \ () -> do
            model <- eval (obj ! "model") :: JS JSNumber
            jQuery "#slider"  <*> slider (cast model)
            jQuery "#fib-out" <*> html ("fib " <> cast model <> "...")
            res <- fib model
            jQuery "#fib-out" <*> html ("fib " <> cast model <> " = " <> cast res)
            control ()

        control ()
    return ()

Summary

Demo - Tanks