Skip to content

Commit

Permalink
Snap init
Browse files Browse the repository at this point in the history
  • Loading branch information
@norm2782
norm2782 committed Apr 7, 2011
1 parent 823aafc commit f88bce9
Show file tree
Hide file tree
Showing 9 changed files with 423 additions and 22 deletions.
74 changes: 52 additions & 22 deletions trunk/JCU.cabal
View file
@@ -1,23 +1,53 @@
name: JCU
version: 0.0.1
synopsis: JCU
description: JCU
license: BSD3
license-file: LICENSE
category: Compilers/Interpreters
copyright: (c) 2011 Utrecht University
author: Jurriën Stutterheim
maintainer: Jurriën Stutterheim
stability: provisional
homepage: http://www.cs.uu.nl/wiki/bin/view/Center/JCU
tested-with: GHC == 7.0.3
build-type: Simple
cabal-version: >= 1.2
extra-source-files: Makefile
Name: JCU
Version: 0.1
Synopsis: Project Synopsis Here
Description: Project Description Here
License: BSD3
license-file: LICENSE
Author: Jurriën Stutterheim
Maintainer: Jurriën Stutterheim
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 trunk
hs-source-dirs: src
main-is: Main.hs

Build-depends:
base >= 4 && < 5,
bytestring >= 0.9.1 && < 0.10,
heist >= 0.5 && < 0.6,
MonadCatchIO-transformers >= 0.2.1 && < 0.3,
mtl >= 2 && < 3,
snap == 0.4.*,
snap-core == 0.4.*,
snap-server == 0.4.*,
text >= 0.11 && < 0.12,
time >= 1.1 && < 1.3,
xmlhtml == 0.1.*

extensions: TypeSynonymInstances MultiParamTypeClasses

if flag(development)
cpp-options: -DDEVELOPMENT
build-depends: hint >= 0.3.2 && < 0.4
-- 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

executable jcu
main-is: GUI.hs
build-depends: base >= 4.3 && < 5, wx >= 0.12, uu-parsinglib >= 2.7.1,
wxcore >= 0.12
other-modules: Prolog
hs-source-dirs: src
26 changes: 26 additions & 0 deletions trunk/resources/static/screen.css
View file
@@ -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%;
}
13 changes: 13 additions & 0 deletions trunk/resources/templates/echo.tpl
View file
@@ -0,0 +1,13 @@
<html>
<head>
<title>Echo Page</title>
</head>
<body>
<div id="content">
<h1>Is there an echo in here?</h1>
</div>
<p>You wanted me to say this?</p>
<p>"<message/>"</p>
<p><a href="/">Return</a></p>
</body>
</html>
32 changes: 32 additions & 0 deletions trunk/resources/templates/index.tpl
View file
@@ -0,0 +1,32 @@
<html>
<head>
<title>Snap web server</title>
<link rel="stylesheet" type="text/css" href="screen.css"/>
</head>
<body>
<div id="content">
<h1>It works!</h1>
<p>
This is a simple demo page served using
<a href="http://snapframework.com/docs/tutorials/heist">Heist</a>
and the <a href="http://snapframework.com/">Snap</a> web framework.
</p>
<p>
Echo test:
<a href="/echo/cats">cats</a>
<a href="/echo/dogs">dogs</a>
<a href="/echo/fish">fish</a>
</p>
<table id="info">
<tr>
<td>Config generated at:</td>
<td><start-time/></td>
</tr>
<tr>
<td>Page generated at:</td>
<td><current-time/></td>
</tr>
</table>
</div>
</body>
</html>
58 changes: 58 additions & 0 deletions trunk/src/Application.hs
View file
@@ -0,0 +1,58 @@
{-
This module defines our application's monad and any application-specific
information it requires.
-}

module Application
( Application
, applicationInitializer
) where

import Snap.Extension
import Snap.Extension.Heist.Impl
import Snap.Extension.Timer.Impl


------------------------------------------------------------------------------
-- | 'Application' is our application's monad. It uses 'SnapExtend' from
-- 'Snap.Extension' to provide us with an extended 'MonadSnap' making use of
-- the Heist and Timer Snap extensions.
type Application = SnapExtend ApplicationState


------------------------------------------------------------------------------
-- | 'ApplicationState' is a record which contains the state needed by the Snap
-- extensions we're using. We're using Heist so we can easily render Heist
-- templates, and Timer simply to illustrate the config loading differences
-- between development and production modes.
data ApplicationState = ApplicationState
{ templateState :: HeistState Application
, timerState :: TimerState
}


------------------------------------------------------------------------------
instance HasHeistState Application ApplicationState where
getHeistState = templateState
setHeistState s a = a { templateState = s }


------------------------------------------------------------------------------
instance HasTimerState ApplicationState where
getTimerState = timerState
setTimerState s a = a { timerState = s }


------------------------------------------------------------------------------
-- | The 'Initializer' for ApplicationState. For more on 'Initializer's, see
-- the documentation from the snap package. Briefly, this is used to
-- generate the 'ApplicationState' needed for our application and will
-- automatically generate reload\/cleanup actions for us which we don't need
-- to worry about.
applicationInitializer :: Initializer ApplicationState
applicationInitializer = do
heist <- heistInitializer "resources/templates"
timer <- timerInitializer
return $ ApplicationState heist timer
65 changes: 65 additions & 0 deletions trunk/src/Main.hs
View file
@@ -0,0 +1,65 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}

{-|
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.
-}

module Main where

#ifdef DEVELOPMENT
import Snap.Extension.Loader.Devel
import Snap.Http.Server (quickHttpServe)
#else
import Snap.Extension.Server
#endif

import Application
import Site

main :: IO ()
#ifdef DEVELOPMENT
main = do
-- All source directories will be watched for updates
-- automatically. If any extra directories should be watched for
-- updates, include them here.
snap <- $(let extraWatcheDirs = ["resources/templates"]
in loadSnapTH 'applicationInitializer 'site extraWatcheDirs)
quickHttpServe snap
#else
main = quickHttpServe applicationInitializer site
#endif
57 changes: 57 additions & 0 deletions trunk/src/Site.hs
View file
@@ -0,0 +1,57 @@
{-# LANGUAGE OverloadedStrings #-}

{-|
This is where all the routes and handlers are defined for your site. The
'site' function combines everything together and is exported by this module.
-}

module Site
( site
) where

import Control.Applicative
import Data.Maybe
import qualified Data.Text.Encoding as T
import Snap.Extension.Heist
import Snap.Extension.Timer
import Snap.Util.FileServe
import Snap.Types
import Text.Templating.Heist

import Application


------------------------------------------------------------------------------
-- | Renders the front page of the sample site.
--
-- The 'ifTop' is required to limit this to the top of a route.
-- Otherwise, the way the route table is currently set up, this action
-- would be given every request.
index :: Application ()
index = ifTop $ heistLocal (bindSplices indexSplices) $ render "index"
where
indexSplices =
[ ("start-time", startTimeSplice)
, ("current-time", currentTimeSplice)
]


------------------------------------------------------------------------------
-- | Renders the echo page.
echo :: Application ()
echo = do
message <- decodedParam "stuff"
heistLocal (bindString "message" (T.decodeUtf8 message)) $ render "echo"
where
decodedParam p = fromMaybe "" <$> getParam p


------------------------------------------------------------------------------
-- | The main entry point handler.
site :: Application ()
site = route [ ("/", index)
, ("/echo/:stuff", echo)
]
<|> serveDirectory "resources/static"
53 changes: 53 additions & 0 deletions trunk/src/Snap/Extension/Timer.hs
View file
@@ -0,0 +1,53 @@
{-|
'Snap.Extension.Timer' exports the 'MonadTimer' interface which allows you to
keep track of the time at which your application was started. The interface's
only operation is 'startTime'.
Two splices, 'startTimeSplice' and 'currentTimeSplice' are also provided, for
your convenience.
'Snap.Extension.Timer.Timer' contains the only implementation of this
interface and can be used to turn your application's monad into a
'MonadTimer'.
More than anything else, this is intended to serve as an example Snap
Extension to any developer wishing to write their own Snap Extension.
-}

module Snap.Extension.Timer
( MonadTimer(..)
, startTimeSplice
, currentTimeSplice
) where

import Control.Monad.Trans
import Data.Time.Clock
import qualified Data.Text as T
import Snap.Types
import Text.Templating.Heist
import Text.XmlHtml


------------------------------------------------------------------------------
-- | The 'MonadTimer' type class. Minimal complete definition: 'startTime'.
class MonadSnap m => MonadTimer m where
-- | The time at which your application was last loaded.
startTime :: m UTCTime


------------------------------------------------------------------------------
-- | For your convenience, a splice which shows the start time.
startTimeSplice :: MonadTimer m => Splice m
startTimeSplice = do
time <- lift startTime
return $ [TextNode $ T.pack $ show $ time]


------------------------------------------------------------------------------
-- | For your convenience, a splice which shows the current time.
currentTimeSplice :: MonadTimer m => Splice m
currentTimeSplice = do
time <- lift $ liftIO getCurrentTime
return $ [TextNode $ T.pack $ show $ time]

0 comments on commit f88bce9

Please sign in to comment.