transient-universe-0.3.4: examples/webapp.hs

{-# LANGUAGE   CPP #-}

module Main where

import Prelude hiding (div,id,span)
import Transient.Base
#ifdef ghcjs_HOST_OS
   hiding ( option)
#endif
import GHCJS.HPlay.View
#ifdef ghcjs_HOST_OS
   hiding (map)
#else
   hiding (map, option)
#endif

import Transient.Move
import Transient.Indeterminism
import Control.Applicative
import Control.Monad
import Data.Typeable
import Data.IORef
import Control.Concurrent (threadDelay)
import Control.Monad.IO.Class


-- Show the composability of transient web aplications
-- with three examples composed together, each one is a widget that execute
-- code in the browser AND the server.

main = simpleWebApp 8080 $  demo <|> demo2  <|>  counters



demo= do
   name <- local . render $ do
       rawHtml $ do
          hr
          p "this snippet captures the essence of this demonstration"
          p $ do
             span "it's a blend of server and browser code in a "
             span $ b "composable"
             span " piece"

          div ! id (fs "fibs") $ i "Fibonacci numbers should appear here"

   local . render $ wlink () (p " stream fibonacci numbers")

   -- stream fibonacci

   r <-  atRemote $ do
               let fibs= 0 : 1 : zipWith (+) fibs (tail fibs) :: [Int]  -- fibonacci numb. definition

               r <- local  . threads 1 . choose $ take 10 fibs
               lliftIO $ print r
               lliftIO $ threadDelay 1000000
               return r

   local . render . at (fs "#fibs") Append $ rawHtml $  (h2 r)



demo2= do
   name <- local . render $ do
       rawHtml $ do
          hr
          br;br
          p "In this example you enter your name and the server will salute you"
          br

--       inputString (Just "Your name") `fire` OnKeyUp       -- send once a char is entered
       inputString Nothing ! atr "placeholder" (fs "enter your name") `fire` OnKeyUp
             <++ br                                        -- new line

   r <- atRemote $ lliftIO $ print (name ++ " calling") >> return ("Hi " ++ name)

   local . render . rawHtml $ do
            p " returned"
            h2 r



fs= toJSString




counters= do
   local . render . rawHtml $ do
          hr
          p "To demonstrate the use of teleport, widgets, interactive streaming"
          p "and composability in a web application."
          br
          p "This is one of the most complicated interactions: how to control a stream in the server"
          p "by means of a web interface without loosing composability."
          br
          p "in this example, events flow from the server to the browser (a counter) and back from"
          p "the browser to the server (initiating and cancelling the counters)"

--   server <- local $ getSData <|> error "no server???"
   counter  <|> counter

   where
   counter  =  do
         op <-  startOrCancel
         teleport          -- translates the computation to the server
         r <- local $ case op of
                   "start"  ->  killChilds >> stream
                   "cancel" ->  killChilds >> stop

         teleport          -- back to the browser again
         local $ render $ rawHtml $ h1 r

   -- generates a sequence of numbers
   stream= do
     counter <- liftIO $ newIORef (0 :: Int)
     waitEvents $ do
          n <- atomicModifyIORef counter $ \r -> (r +1,r)
          threadDelay 1000000
          putStr "generating: " >> print n
          return  n

startOrCancel :: Cloud String
startOrCancel= local $ render $   (inputSubmit "start"  `fire` OnClick)
                              <|> (inputSubmit "cancel" `fire` OnClick)
                              <++ br