This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap-core".
The branch, master has been updated
via 35f1d3db308ab2ded79f84a50feb124326b6f07e (commit)
from 1f969fe10cad0ace8fa35ca2734e348971cba72d (commit)
Summary of changes:
project_template/{ => barebones}/foo.cabal | 4 -
project_template/barebones/src/Common.hs | 59 ++++++++++
project_template/{ => barebones}/src/Main.hs | 1 -
project_template/{ => default}/foo.cabal | 0
project_template/default/src/Common.hs | 151 ++++++++++++++++++++++++++
project_template/{ => default}/src/Main.hs | 0
project_template/src/Common.hs | 151 --------------------------
src/Snap/Starter.hs | 61 ++++++++---
src/Snap/StarterTH.hs | 18 ++--
9 files changed, 264 insertions(+), 181 deletions(-)
copy project_template/{ => barebones}/foo.cabal (91%)
create mode 100644 project_template/barebones/src/Common.hs
copy project_template/{ => barebones}/src/Main.hs (95%)
rename project_template/{ => default}/foo.cabal (100%)
create mode 100644 project_template/default/src/Common.hs
rename project_template/{ => default}/src/Main.hs (100%)
delete mode 100644 project_template/src/Common.hs
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 35f1d3db308ab2ded79f84a50feb124326b6f07e
Author: Shu-yu Guo <[email protected]>
Date: Fri May 28 17:38:13 2010 -0700
Re-add barebones flag to snap init
diff --git a/project_template/foo.cabal b/project_template/barebones/foo.cabal
similarity index 91%
copy from project_template/foo.cabal
copy to project_template/barebones/foo.cabal
index 0fdaa77..b9a0869 100644
--- a/project_template/foo.cabal
+++ b/project_template/barebones/foo.cabal
@@ -21,11 +21,7 @@ Executable projname
bytestring >= 0.9.1 && <0.10,
snap-core >= 0.2 && <0.3,
snap-server >= 0.2 && <0.3,
- heist >= 0.1 && <0.2,
- hexpat == 0.16,
- xhtml-combinators,
unix,
- text,
containers,
MonadCatchIO-transformers,
filepath >= 1.1 && <1.2
diff --git a/project_template/barebones/src/Common.hs
b/project_template/barebones/src/Common.hs
new file mode 100644
index 0000000..5dcc3e7
--- /dev/null
+++ b/project_template/barebones/src/Common.hs
@@ -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 ()
+
diff --git a/project_template/src/Main.hs
b/project_template/barebones/src/Main.hs
similarity index 95%
copy from project_template/src/Main.hs
copy to project_template/barebones/src/Main.hs
index 4699c3f..464348b 100644
--- a/project_template/src/Main.hs
+++ b/project_template/barebones/src/Main.hs
@@ -9,7 +9,6 @@ import Common
config :: AppConfig
config = AppConfig {
- templateDir = "templates",
accessLog = Just "access.log",
errorLog = Just "error.log"
}
diff --git a/project_template/foo.cabal b/project_template/default/foo.cabal
similarity index 100%
rename from project_template/foo.cabal
rename to project_template/default/foo.cabal
diff --git a/project_template/default/src/Common.hs
b/project_template/default/src/Common.hs
new file mode 100644
index 0000000..1df3d36
--- /dev/null
+++ b/project_template/default/src/Common.hs
@@ -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 ()
+
diff --git a/project_template/src/Main.hs b/project_template/default/src/Main.hs
similarity index 100%
rename from project_template/src/Main.hs
rename to project_template/default/src/Main.hs
diff --git a/project_template/src/Common.hs b/project_template/src/Common.hs
deleted file mode 100644
index 42c05c0..0000000
--- a/project_template/src/Common.hs
+++ /dev/null
@@ -1,151 +0,0 @@
-{-# 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 ()
-
diff --git a/src/Snap/Starter.hs b/src/Snap/Starter.hs
index 03d522f..7c8f872 100644
--- a/src/Snap/Starter.hs
+++ b/src/Snap/Starter.hs
@@ -2,11 +2,12 @@
module Main where
------------------------------------------------------------------------------
-import Data.List
+import Data.List
import qualified Data.Text as T
-import System
-import System.Directory
-import System.FilePath
+import System
+import System.Directory
+import System.Console.GetOpt
+import System.FilePath
------------------------------------------------------------------------------
import Snap.StarterTH
@@ -14,7 +15,8 @@ import Snap.StarterTH
------------------------------------------------------------------------------
-- Creates a value tDir :: ([String], [(String, String)])
-$(buildData "tDir")
+$(buildData "tDirDefault" "default")
+$(buildData "tDirBareBones" "barebones")
------------------------------------------------------------------------------
@@ -35,8 +37,8 @@ data InitFlag = InitBareBones
deriving (Show, Eq)
-setup :: String -> IO ()
-setup projName = do
+setup :: String -> ([FilePath], [(String, String)]) -> IO ()
+setup projName tDir = do
mapM createDirectory (fst tDir)
mapM_ write (snd tDir)
where
@@ -49,12 +51,39 @@ setup projName = do
(T.pack projName) c
------------------------------------------------------------------------------
-initProject :: IO ()
-initProject = do
- cur <- getCurrentDirectory
- let dirs = splitDirectories cur
- projName = last dirs
- setup projName
+initProject :: [String] -> IO ()
+initProject args = do
+ case getOpt Permute options args of
+ (flags, _, [])
+ | InitHelp `elem` flags -> do putStrLn initUsage
+ exitFailure
+ | otherwise -> init' (InitBareBones `elem` flags)
+
+ (_, _, errs) -> do putStrLn $ concat errs
+ putStrLn initUsage
+ exitFailure
+ where
+ initUsage = unlines
+ ["Usage:"
+ ,""
+ ," snap init"
+ ,""
+ ," -b --barebones Depend only on -core and -server"
+ ," -h --help Print this message"
+ ]
+
+ options =
+ [ Option ['b'] ["barebones"] (NoArg InitBareBones)
+ "Depend only on -core and -server"
+ , Option ['h'] ["help"] (NoArg InitHelp)
+ "Print this message"
+ ]
+
+ init' isBareBones = do
+ cur <- getCurrentDirectory
+ let dirs = splitDirectories cur
+ projName = last dirs
+ setup projName (if isBareBones then tDirBareBones else tDirDefault)
------------------------------------------------------------------------------
@@ -62,7 +91,7 @@ main :: IO ()
main = do
args <- getArgs
case args of
- ("init":_) -> initProject
- _ -> do putStrLn usage
- exitFailure
+ ("init":args') -> initProject args'
+ _ -> do putStrLn usage
+ exitFailure
diff --git a/src/Snap/StarterTH.hs b/src/Snap/StarterTH.hs
index 04d9091..17f8cce 100644
--- a/src/Snap/StarterTH.hs
+++ b/src/Snap/StarterTH.hs
@@ -12,12 +12,12 @@ import System.Directory.Tree
------------------------------------------------------------------------------
-- Convenience types
type FileData = (String, String)
-type DirData = String
+type DirData = FilePath
------------------------------------------------------------------------------
-- Gets all the directorys in a DirTree
-getDirs :: [String] -> DirTree a -> [String]
+getDirs :: [FilePath] -> DirTree a -> [FilePath]
getDirs prefix (Dir n c) = (intercalate "/" (reverse (n:prefix))) : concatMap
(getDirs (n:prefix)) c
getDirs _ (File _ _) = []
getDirs _ (Failed _ _) = []
@@ -26,7 +26,7 @@ getDirs _ (Failed _ _) = []
------------------------------------------------------------------------------
-- Reads a directory and returns a tuple of the list of all directories
-- encountered and a list of filenames and content strings.
-readTree :: String -> IO ([DirData], [FileData])
+readTree :: FilePath -> IO ([DirData], [FileData])
readTree dir = do
d <- readDirectory $ dir++"/."
let ps = zipPaths $ "" :/ (free d)
@@ -37,19 +37,19 @@ readTree dir = do
------------------------------------------------------------------------------
-- Calls readTree and returns it's value in a quasiquote.
-dirQ :: Q Exp
-dirQ = do
- d <- runIO $ readTree "project_template"
+dirQ :: FilePath -> Q Exp
+dirQ tplDir = do
+ d <- runIO $ readTree $ "project_template/"++tplDir
runQ [| d |]
------------------------------------------------------------------------------
-- Creates a declaration assigning the specified name the value returned by
-- dirQ.
-buildData :: String -> Q [Dec]
-buildData dirName = do
+buildData :: String -> FilePath -> Q [Dec]
+buildData dirName tplDir = do
v <- valD (varP (mkName dirName))
- (normalB dirQ)
+ (normalB $ dirQ tplDir)
[]
return [v]
-----------------------------------------------------------------------
hooks/post-receive
--
snap-core
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
