Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

UNDER. PANTS.

  • Loading branch information...
commit f55ac870dce249003aec0ab7821b2a377debb637 0 parents
@bos authored
Showing with 172 additions and 0 deletions.
  1. +12 −0 src/Application.hs
  2. +68 −0 src/Main.hs
  3. +40 −0 src/Site.hs
  4. +52 −0 underpants.cabal
12 src/Application.hs
@@ -0,0 +1,12 @@
+module Application
+ ( Application
+ , applicationInitializer
+ ) where
+
+import Snap.Extension
+
+type Application = SnapExtend ApplicationState
+type ApplicationState = ()
+
+applicationInitializer :: Initializer ApplicationState
+applicationInitializer = return ()
68 src/Main.hs
@@ -0,0 +1,68 @@
+{-# 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 Control.Exception (SomeException, try)
+
+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, cleanup) <- $(let watchDirs = ["resources/templates"]
+ in loadSnapTH 'applicationInitializer 'site watchDirs)
+ try $ quickHttpServe snap :: IO (Either SomeException ())
+ cleanup
+#else
+main = quickHttpServe applicationInitializer site
+#endif
40 src/Site.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Site (site) where
+
+import Application
+import Control.Applicative ((<$>))
+import Control.Exception (SomeException)
+import Control.Monad (when)
+import Control.Monad.CatchIO (try)
+import Data.Aeson (FromJSON, Result(..), ToJSON, Value, encode, fromJSON, json)
+import Data.Attoparsec.Enumerator (iterParser)
+import Snap.Internal.Iteratee.Debug (iterateeDebugWrapper)
+import Snap.Types
+
+
+decodeJSONRequest :: FromJSON a => MonadSnap m => m a
+decodeJSONRequest = withRequest $ \req -> do
+ let ctype = getHeader "Content-Type" req
+ when (ctype /= Just "application/json") .
+ withResponse $ finishWith . setResponseCode 415
+ jreq <- runRequestBody . try . iterateeDebugWrapper "json" $ iterParser json
+ case (fromJSON <$> jreq) :: FromJSON a => Either SomeException (Result a) of
+ Right (Success r) -> return r
+ _ -> do
+ modifyResponse $ setResponseCode 400
+ writeText "unable to parse or convert request"
+ finishWith =<< getResponse
+
+respond :: ToJSON a => a -> Application ()
+respond v = do
+ modifyResponse $ setContentType "application/json"
+ writeLBS (encode v)
+
+underpants :: Application ()
+underpants = do
+ undies <- decodeJSONRequest
+ respond (undies::Value)
+
+site :: Application ()
+site = route [ ("/", underpants) ]
52 underpants.cabal
@@ -0,0 +1,52 @@
+Name: underpants
+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 underpants
+ hs-source-dirs: src
+ main-is: Main.hs
+
+ Build-depends:
+ aeson,
+ attoparsec-enumerator,
+ base >= 4 && < 5,
+ bytestring >= 0.9.1 && < 0.10,
+ MonadCatchIO-transformers >= 0.2.1 && < 0.3,
+ mtl >= 2 && < 3,
+ snap == 0.5.*,
+ snap-core == 0.5.*,
+ snap-server == 0.5.*,
+ text >= 0.11 && < 0.12,
+ time >= 1.1 && < 1.3
+
+ 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
+
Please sign in to comment.
Something went wrong with that request. Please try again.