Permalink
Browse files

Started with Snap.

  • Loading branch information...
1 parent 4ccacc1 commit ce2864cb5f1ff3df70729bebfd289859ed8c09f2 @tomlokhorst committed Jun 9, 2011
View
@@ -1,2 +1,3 @@
+log
dist
*.swp
View
@@ -1,26 +1,52 @@
-name: dutchhug-nl
-version: 0.0.0
-license: BSD3
-license-file: LICENSE
-author: Tom Lokhorst tom@lokhorst.eu
-maintainer: Tom Lokhorst tom@lokhorst.eu
-synopsis: A web application based on Yesod.
-description: The default web application. You might want to change this.
-category: Web
-stability: Stable
-cabal-version: >= 1.2
-build-type: Simple
-homepage: http://dutchhug.nl/
+Name: dutchhug-nl
+Version: 0.2
+Synopsis: DutchHUG.nl website
+Description: Website for the Dutch Haskell User Group.
+License: BSD3
+Author: Tom Lokhorst
+Maintainer: tom@lokhorst.eu
+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 dutchhug-nl
+ 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 dutchhug-nl
- hs-source-dirs: src
- build-depends: base >= 4 && < 5,
- yesod >= 0.0.0 && < 0.1,
- safe-failure >= 0.4.0 && < 0.5,
- data-object-yaml >= 0.2.0.1 && < 0.3,
- HStringTemplate >= 0.6.2 && <0.7,
- HTTP >= 4000.0.9 && < 4000.1,
- tagsoup >= 0.8 && < 0.9,
- unix >= 2.4.0 && < 2.5
- main-is: DutchHug.hs
- ghc-options: -Wall
@@ -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%;
+}
@@ -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>
@@ -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>
View
@@ -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
View
@@ -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
View
@@ -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"
@@ -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]
Oops, something went wrong.

0 comments on commit ce2864c

Please sign in to comment.