Started with Snap.

tomlokhorst · Jun 9, 2011 · ce2864c · ce2864c
1 parent 4ccacc1
commit ce2864c
Show file tree

Hide file tree

Showing 10 changed files with 423 additions and 25 deletions.
diff --git a/.gitignore b/.gitignore
@@ -1,2 +1,3 @@
+log
 dist
 *.swp
diff --git a/dutchhug-nl.cabal b/dutchhug-nl.cabal
@@ -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
diff --git a/resources/static/screen.css b/resources/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%;
+}
diff --git a/resources/templates/echo.tpl b/resources/templates/echo.tpl
@@ -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>
diff --git a/resources/templates/index.tpl b/resources/templates/index.tpl
@@ -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>
diff --git a/src/Application.hs b/src/Application.hs
@@ -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
diff --git a/src/Main.hs b/src/Main.hs
@@ -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
diff --git a/src/Site.hs b/src/Site.hs
@@ -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"
diff --git a/src/Snap/Extension/Timer.hs b/src/Snap/Extension/Timer.hs
@@ -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]