diff --git a/.gitignore b/.gitignore index d1b22e5..52b4649 100644 --- 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 new file mode 100644 index 0000000..a882c32 --- /dev/null +++ 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 new file mode 100644 index 0000000..a2d2bbc --- /dev/null +++ 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 new file mode 100644 index 0000000..4dce528 --- /dev/null +++ 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 new file mode 100644 index 0000000..b4edea4 --- /dev/null +++ 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 new file mode 100644 index 0000000..6776417 --- /dev/null +++ b/example/snaplets/heist/templates/base.tpl @@ -0,0 +1,13 @@ + + + Snap web server + + + +
+ + + +
+ + diff --git a/example/snaplets/heist/templates/index.tpl b/example/snaplets/heist/templates/index.tpl new file mode 100644 index 0000000..0585c54 --- /dev/null +++ b/example/snaplets/heist/templates/index.tpl @@ -0,0 +1,12 @@ + + + Snaplet Fay Example Application + + + + +
+

Snaplet Fay Example Application

+
+ + diff --git a/example/src/Application.hs b/example/src/Application.hs new file mode 100644 index 0000000..e0bd9a2 --- /dev/null +++ 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 new file mode 100644 index 0000000..8901462 --- /dev/null +++ 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 new file mode 100644 index 0000000..92daedc --- /dev/null +++ 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 new file mode 100644 index 0000000..b052609 --- /dev/null +++ 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%; +}