Permalink
Browse files

Re-add barebones flag to snap init

  • Loading branch information...
1 parent 1f969fe commit 35f1d3db308ab2ded79f84a50feb124326b6f07e @syg syg committed May 29, 2010
@@ -0,0 +1,33 @@
+Name: projname
+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
+
+Executable projname
+ hs-source-dirs: src
+ main-is: Main.hs
+
+ Build-depends:
+ base >= 4,
+ haskell98,
+ monads-fd >= 0.1 && <0.2,
+ bytestring >= 0.9.1 && <0.10,
+ snap-core >= 0.2 && <0.3,
+ snap-server >= 0.2 && <0.3,
+ unix,
+ containers,
+ MonadCatchIO-transformers,
+ filepath >= 1.1 && <1.2
+
+ if impl(ghc >= 6.12.0)
+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
+ -fno-warn-unused-do-bind
+ else
+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
@@ -0,0 +1,59 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Common where
+
+import Control.Concurrent
+import Control.Exception (SomeException)
+import Control.Monad
+import Control.Monad.CatchIO
+import Prelude hiding (catch)
+import Snap.Http.Server
+import Snap.Types
+import Snap.Util.GZip
+import System
+import System.Posix.Env
+
+setLocaleToUTF8 :: IO ()
+setLocaleToUTF8 = do
+ mapM_ (\k -> setEnv k "en_US.UTF-8" True)
+ [ "LANG"
+ , "LC_CTYPE"
+ , "LC_NUMERIC"
+ , "LC_TIME"
+ , "LC_COLLATE"
+ , "LC_MONETARY"
+ , "LC_MESSAGES"
+ , "LC_PAPER"
+ , "LC_NAME"
+ , "LC_ADDRESS"
+ , "LC_TELEPHONE"
+ , "LC_MEASUREMENT"
+ , "LC_IDENTIFICATION"
+ , "LC_ALL" ]
+
+data AppConfig = AppConfig {
+ accessLog :: Maybe FilePath,
+ errorLog :: Maybe FilePath
+}
+
+quickServer :: AppConfig -> Snap () -> IO ()
+quickServer config siteHandlers = do
+ args <- getArgs
+ port <- case args of
+ [] -> error "You must specify a port!" >> exitFailure
+ (port:_) -> return $ read port
+
+ setLocaleToUTF8
+
+ (try $ httpServe "*" port "myserver"
+ (accessLog config)
+ (errorLog config)
+ (withCompression siteHandlers))
+ :: IO (Either SomeException ())
+
+ threadDelay 1000000
+ putStrLn "exiting"
+ return ()
+
@@ -0,0 +1,33 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+import Control.Applicative
+import Snap.Types
+import Snap.Util.FileServe
+
+import Common
+
+config :: AppConfig
+config = AppConfig {
+ accessLog = Just "access.log",
+ errorLog = Just "error.log"
+}
+
+main :: IO ()
+main = do
+ quickServer config site
+
+site :: Snap ()
+site =
+ ifTop (writeBS "hello world") <|>
+ route [ ("foo", writeBS "bar")
+ , ("echo/:echoparam", echoHandler)
+ ] <|>
+ dir "static" (fileServe ".")
+
+echoHandler :: Snap ()
+echoHandler = do
+ param <- getParam "echoparam"
+ maybe (writeBS "must specify echo/param in URL")
+ writeBS param
+
File renamed without changes.
@@ -0,0 +1,151 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Common where
+
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.Maybe
+import qualified Data.Text as T
+import Control.Applicative
+import Control.Concurrent
+import Control.Exception (SomeException)
+import Control.Monad
+import Control.Monad.CatchIO
+import Control.Monad.Trans
+import Prelude hiding (catch)
+import Snap.Http.Server
+import Snap.Types
+import Snap.Util.FileServe
+import Snap.Util.GZip
+import System
+import System.Posix.Env
+import Text.Templating.Heist
+import Text.Templating.Heist.Splices.Static
+import qualified Text.XHtmlCombinators.Escape as XH
+
+
+setLocaleToUTF8 :: IO ()
+setLocaleToUTF8 = do
+ mapM_ (\k -> setEnv k "en_US.UTF-8" True)
+ [ "LANG"
+ , "LC_CTYPE"
+ , "LC_NUMERIC"
+ , "LC_TIME"
+ , "LC_COLLATE"
+ , "LC_MONETARY"
+ , "LC_MESSAGES"
+ , "LC_PAPER"
+ , "LC_NAME"
+ , "LC_ADDRESS"
+ , "LC_TELEPHONE"
+ , "LC_MEASUREMENT"
+ , "LC_IDENTIFICATION"
+ , "LC_ALL" ]
+
+
+------------------------------------------------------------------------------
+-- General purpose code. This code will eventually get moved into Snap once
+-- we have a good place to put it.
+------------------------------------------------------------------------------
+
+------------------------------------------------------------------------------
+-- |
+renderTmpl :: MVar (TemplateState Snap)
+ -> ByteString
+ -> Snap ()
+renderTmpl tsMVar n = do
+ ts <- liftIO $ readMVar tsMVar
+ maybe pass writeBS =<< renderTemplate ts n
+
+
+templateServe :: TemplateState Snap
+ -> MVar (TemplateState Snap)
+ -> StaticTagState
+ -> Snap ()
+templateServe orig tsMVar staticState = do
+ p
+ modifyResponse $ setContentType "text/html"
+
+ where
+ p = ifTop (renderTmpl tsMVar "index") <|>
+ path "admin/reload" (reloadTemplates orig tsMVar staticState) <|>
+ (renderTmpl tsMVar . B.pack =<< getSafePath)
+
+
+loadError :: String -> String
+loadError str = "Error loading templates\n"++str
+
+reloadTemplates :: TemplateState Snap
+ -> MVar (TemplateState Snap)
+ -> StaticTagState
+ -> Snap ()
+reloadTemplates origTs tsMVar staticState = do
+ liftIO $ clearStaticTagCache staticState
+ ts <- liftIO $ loadTemplates "templates" origTs
+ either bad good ts
+ where
+ bad msg = do writeBS $ B.pack $ loadError msg ++ "Keeping old templates."
+ good ts = do liftIO $ modifyMVar_ tsMVar (const $ return ts)
+ writeBS "Templates loaded successfully"
+
+
+basicHandlers :: TemplateState Snap
+ -> MVar (TemplateState Snap)
+ -> StaticTagState
+ -> Snap ()
+ -> Snap ()
+basicHandlers origTs tsMVar staticState userHandlers =
+ catch500 $ withCompression $
+ userHandlers <|>
+ templateServe origTs tsMVar staticState
+
+
+catch500 :: Snap a -> Snap ()
+catch500 m = (m >> return ()) `catch` \(e::SomeException) -> do
+ let t = T.pack $ show e
+ putResponse r
+ writeBS "<html><head><title>Internal Server Error</title></head>"
+ writeBS "<body><h1>Internal Server Error</h1>"
+ writeBS "<p>A web handler threw an exception. Details:</p>"
+ writeBS "<pre>\n"
+ writeText $ XH.escape t
+ writeBS "\n</pre></body></html>"
+
+ where
+ r = setContentType "text/html" $
+ setResponseStatus 500 "Internal Server Error" emptyResponse
+
+data AppConfig = AppConfig {
+ templateDir :: FilePath,
+ accessLog :: Maybe FilePath,
+ errorLog :: Maybe FilePath
+}
+
+quickServer :: AppConfig -> Snap () -> IO ()
+quickServer config siteHandlers = do
+ args <- getArgs
+ port <- case args of
+ [] -> error "You must specify a port!" >> exitFailure
+ (port:_) -> return $ read port
+
+ setLocaleToUTF8
+
+ (origTs,staticState) <- bindStaticTag emptyTemplateState
+
+ ets <- loadTemplates (templateDir config) origTs
+ let ts = either error id ets
+ either (\s -> putStrLn (loadError s) >> exitFailure) (const $ return ()) ets
+ tsMVar <- newMVar $ ts
+
+ (try $ httpServe "*" port "myserver"
+ (accessLog config)
+ (errorLog config)
+ (basicHandlers origTs tsMVar staticState siteHandlers))
+ :: IO (Either SomeException ())
+
+ threadDelay 1000000
+ putStrLn "exiting"
+ return ()
+
File renamed without changes.
Oops, something went wrong.

0 comments on commit 35f1d3d

Please sign in to comment.