Added example application

faylang · Aug 11, 2012 · eb0ce02 · eb0ce02
1 parent 7321fdb
commit eb0ce02
Show file tree

Hide file tree

Showing 11 changed files with 361 additions and 0 deletions.
diff --git a/.gitignore b/.gitignore
@@ -1,2 +1,6 @@
 dist
 test-dest
+example/log
+example/snaplets/fay/devel.cfg
+example/snaplets/fay/js
+
diff --git a/example/.ghci b/example/.ghci
@@ -0,0 +1,4 @@
+:set -isrc
+:set -hide-package MonadCatchIO-mtl
+:set -hide-package monads-fd
+:set -XOverloadedStrings
diff --git a/example/example.cabal b/example/example.cabal
@@ -0,0 +1,54 @@
+Name:                example
+Version:             0.1
+Synopsis:            Project Synopsis Here
+Description:         Project Description Here
+License:             AllRightsReserved
+Author:              Author
+Maintainer:          maintainer@example.com
+Stability:           Experimental
+Category:            Web
+Build-type:          Simple
+Cabal-version:       >=1.2
+
+Flag development
+  Description: Whether to build the server in development (interpreted) mode
+  Default: False
+
+Executable example
+  hs-source-dirs: src
+  main-is: Main.hs
+
+  Build-depends:
+    base >= 4 && < 5,
+    bytestring >= 0.9.1 && < 0.10,
+    data-lens >= 2.0.1 && < 2.11,
+    data-lens-template >= 2.1 && < 2.2,
+    heist >= 0.8 && < 0.9,
+    MonadCatchIO-transformers >= 0.2.1 && < 0.4,
+    mtl >= 2 && < 3,
+    snap == 0.9.*,
+    snap-core   == 0.9.*,
+    snap-server == 0.9.*,
+    snap-loader-static == 0.9.*,
+    snaplet-fay == 0.1.0.0,
+    text >= 0.11 && < 0.12,
+    time >= 1.1 && < 1.5,
+    xmlhtml >= 0.1
+
+  if flag(development)
+    build-depends:
+      snap-loader-dynamic == 0.9.*
+    cpp-options: -DDEVELOPMENT
+    -- In development mode, speed is already going to suffer, so skip
+    -- the fancy optimization flags.  Additionally, disable all
+    -- warnings.  The hint library doesn't give an option to execute
+    -- compiled code when there were also warnings, so disabling
+    -- warnings allows quicker workflow.
+    ghc-options: -threaded -w
+  else
+    if impl(ghc >= 6.12.0)
+      ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
+                   -fno-warn-orphans -fno-warn-unused-do-bind
+    else
+      ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
+                   -fno-warn-orphans
diff --git a/example/snaplets/fay/src/Dom.hs b/example/snaplets/fay/src/Dom.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Dom where
+
+
+data Element
+instance Foreign Element
+data Event
+instance Foreign Event
+data Global
+instance Foreign Global
+data Document
+instance Foreign Document
+
+head :: [a] -> a
+head (x:_) = x
+
+getBody :: Fay Element
+getBody = firstByTag "body"
+
+getWindow :: Fay Global
+getWindow = ffi "window"
+
+getDocument :: Fay Document
+getDocument = ffi "document"
+
+firstByTag :: String -> Fay Element
+firstByTag tag = byTag tag >>= (return . head)
+
+byTag :: String -> Fay [Element]
+byTag = ffi "document.getElementsByTagName(%1)"
+
+byId :: String -> Fay Element
+byId = ffi "document.getElementById(%1)"
+
+addEvent :: Foreign f => Element -> String -> (Event -> Fay f) -> Fay ()
+addEvent = ffi "%1.addEventListener(%2,%3)"
+
+addOnload :: Foreign f => Fay f -> Fay ()
+addOnload = ffi "window.addEventListener(\"load\", %1)"
+
+stopProp :: Event -> Fay ()
+stopProp = ffi "%1.stopPropagation()"
+
+preventDefault :: Event -> Fay ()
+preventDefault = ffi "%1.preventDefault()"
+
+createElement :: String -> Fay Element
+createElement = ffi "document.createElement(%1)"
+
+setInnerHtml :: Element -> String -> Fay ()
+setInnerHtml = ffi "%1.innerHTML = %2"
+
+appendChild :: Element -> Element -> Fay ()
+appendChild = ffi "%1.appendChild(%2)"
+
+printS :: String -> Fay ()
+printS = ffi "console.log(%1)"
+
+print :: Foreign f => f -> Fay ()
+print = ffi "console.log(%1)"
diff --git a/example/snaplets/fay/src/Index.hs b/example/snaplets/fay/src/Index.hs
@@ -0,0 +1,14 @@
+module Index where
+
+import Dom
+
+main :: Fay ()
+main = addOnload onload
+
+onload :: Fay ()
+onload = do
+  contents <- byId "content"
+  div <- createElement "div"
+  setInnerHtml div "This element was created by Fay through an onload handler!"
+  appendChild contents div
+  return ()
diff --git a/example/snaplets/heist/templates/base.tpl b/example/snaplets/heist/templates/base.tpl
@@ -0,0 +1,13 @@
+<html>
+  <head>
+    <title>Snap web server</title>
+    <link rel="stylesheet" type="text/css" href="/screen.css"/>
+  </head>
+  <body>
+    <div id="content">
+
+      <content/>
+
+    </div>
+  </body>
+</html>
diff --git a/example/snaplets/heist/templates/index.tpl b/example/snaplets/heist/templates/index.tpl
@@ -0,0 +1,12 @@
+<html>
+  <head>
+    <title>Snaplet Fay Example Application</title>
+    <link rel="stylesheet" type="text/css" href="/screen.css"/>
+    <script src="/fay/Index.js"></script>
+  </head>
+  <body>
+    <div id="content">
+      <h1>Snaplet Fay Example Application</h1>
+    </div>
+  </body>
+</html>
diff --git a/example/src/Application.hs b/example/src/Application.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+------------------------------------------------------------------------------
+-- | This module defines our application's state type and an alias for its
+-- handler monad.
+module Application where
+
+------------------------------------------------------------------------------
+import Data.Lens.Template
+import Snap.Snaplet
+import Snap.Snaplet.Heist
+import Snap.Snaplet.Fay
+
+------------------------------------------------------------------------------
+data App = App
+    { _heist :: Snaplet (Heist App)
+    , _fay :: Snaplet Fay
+    }
+
+makeLens ''App
+
+instance HasHeist App where
+    heistLens = subSnaplet heist
+
+
+------------------------------------------------------------------------------
+type AppHandler = Handler App App
+
+
diff --git a/example/src/Main.hs b/example/src/Main.hs
@@ -0,0 +1,102 @@
+{-# LANGUAGE CPP             #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Main where
+
+------------------------------------------------------------------------------
+import           Control.Exception (SomeException, try)
+import qualified Data.Text as T
+import           Snap.Http.Server
+import           Snap.Snaplet
+import           Snap.Snaplet.Config
+import           Snap.Core
+import           System.IO
+import           Site
+
+#ifdef DEVELOPMENT
+import           Snap.Loader.Dynamic
+#else
+import           Snap.Loader.Static
+#endif
+
+
+------------------------------------------------------------------------------
+-- | This is the entry point for this web server application. It supports
+-- easily switching between interpreting source and running statically compiled
+-- code.
+--
+-- In either mode, the generated program should be run from the root of the
+-- project tree. When it is run, it locates its templates, static content, and
+-- source files in development mode, relative to the current working directory.
+--
+-- When compiled with the development flag, only changes to the libraries, your
+-- cabal file, or this file should require a recompile to be picked up.
+-- Everything else is interpreted at runtime. There are a few consequences of
+-- this.
+--
+-- First, this is much slower. Running the interpreter takes a significant
+-- chunk of time (a couple tenths of a second on the author's machine, at this
+-- time), regardless of the simplicity of the loaded code. In order to
+-- recompile and re-load server state as infrequently as possible, the source
+-- directories are watched for updates, as are any extra directories specified
+-- below.
+--
+-- Second, the generated server binary is MUCH larger, since it links in the
+-- GHC API (via the hint library).
+--
+-- Third, and the reason you would ever want to actually compile with
+-- development mode, is that it enables a faster development cycle. You can
+-- simply edit a file, save your changes, and hit reload to see your changes
+-- reflected immediately.
+--
+-- When this is compiled without the development flag, all the actions are
+-- statically compiled in. This results in faster execution, a smaller binary
+-- size, and having to recompile the server for any code change.
+--
+main :: IO ()
+main = do
+    -- Depending on the version of loadSnapTH in scope, this either enables
+    -- dynamic reloading, or compiles it without. The last argument to
+    -- loadSnapTH is a list of additional directories to watch for changes to
+    -- trigger reloads in development mode. It doesn't need to include source
+    -- directories, those are picked up automatically by the splice.
+    (conf, site, cleanup) <- $(loadSnapTH [| getConf |]
+                                          'getActions
+                                          ["snaplets/heist/templates"])
+
+    _ <- try $ httpServe conf site :: IO (Either SomeException ())
+    cleanup
+
+
+------------------------------------------------------------------------------
+-- | This action loads the config used by this application. The loaded config
+-- is returned as the first element of the tuple produced by the loadSnapTH
+-- Splice. The type is not solidly fixed, though it must be an IO action that
+-- produces the same type as 'getActions' takes. It also must be an instance of
+-- Typeable. If the type of this is changed, a full recompile will be needed to
+-- pick up the change, even in development mode.
+--
+-- This action is only run once, regardless of whether development or
+-- production mode is in use.
+getConf :: IO (Config Snap AppConfig)
+getConf = commandLineAppConfig defaultConfig
+
+
+------------------------------------------------------------------------------
+-- | This function generates the the site handler and cleanup action from the
+-- configuration. In production mode, this action is only run once. In
+-- development mode, this action is run whenever the application is reloaded.
+--
+-- Development mode also makes sure that the cleanup actions are run
+-- appropriately before shutdown. The cleanup action returned from loadSnapTH
+-- should still be used after the server has stopped handling requests, as the
+-- cleanup actions are only automatically run when a reload is triggered.
+--
+-- This sample doesn't actually use the config passed in, but more
+-- sophisticated code might.
+getActions :: Config Snap AppConfig -> IO (Snap (), IO ())
+getActions conf = do
+    (msgs, site, cleanup) <- runSnaplet
+        (appEnvironment =<< getOther conf) app
+    hPutStrLn stderr $ T.unpack msgs
+    return (site, cleanup)
diff --git a/example/src/Site.hs b/example/src/Site.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+------------------------------------------------------------------------------
+-- | This module is where all the routes and handlers are defined for your
+-- site. The 'app' function is the initializer that combines everything
+-- together and is exported by this module.
+module Site
+  ( app
+  ) where
+
+------------------------------------------------------------------------------
+import           Control.Applicative
+import           Data.ByteString (ByteString)
+import           Data.Maybe
+import qualified Data.Text as T
+import           Snap.Core
+import           Snap.Snaplet
+import           Snap.Snaplet.Heist
+import           Snap.Snaplet.Fay
+import           Snap.Util.FileServe
+import           Text.Templating.Heist
+------------------------------------------------------------------------------
+import           Application
+
+
+------------------------------------------------------------------------------
+-- | The application's routes.
+routes :: [(ByteString, Handler App App ())]
+routes = [ ("fay", with fay fayServe)
+         , ("",          serveDirectory "static")
+         ]
+
+
+------------------------------------------------------------------------------
+-- | The application initializer.
+app :: SnapletInit App App
+app = makeSnaplet "app" "An snaplet example application." Nothing $ do
+    h <- nestSnaplet "" heist $ heistInit "templates"
+    f <- nestSnaplet "fay" fay $ initFay
+    addRoutes routes
+    return $ App h f
diff --git a/example/static/screen.css b/example/static/screen.css
@@ -0,0 +1,26 @@
+html {
+   padding: 0;
+   margin: 0;
+   background-color: #ffffff;
+   font-family: Verdana, Helvetica, sans-serif;
+}
+body {
+   padding: 0;
+   margin: 0;
+}
+a {
+   text-decoration: underline;
+}
+a :hover {
+   cursor: pointer;
+   text-decoration: underline;
+}
+img {
+   border: none;
+}
+#content {
+   padding-left: 1em;
+}
+#info {
+   font-size: 60%;
+}