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 6cfc5bb3273a7f2e8842f21726f2550424cf46a9 (commit)
via fdb4a77141e6acd1d63057c3917c9c1b062efafb (commit)
from ea5fc3f3b23c940518b775d2b8ba32926d5b9a40 (commit)
Summary of changes:
.ghci | 7 --
project_template/foo.cabal | 37 ----------
project_template/src/Common.hs | 151 ----------------------------------------
project_template/src/Main.hs | 34 ---------
snap-core.cabal | 2 -
src/Snap/Iteratee.hs | 2 +-
src/Snap/Starter.hs | 134 +++++++++++++++++++++++++++--------
src/Snap/StarterTH.hs | 55 ---------------
src/Snap/Util/GZip.hs | 2 +-
9 files changed, 105 insertions(+), 319 deletions(-)
delete mode 100644 .ghci
delete mode 100644 project_template/foo.cabal
delete mode 100644 project_template/src/Common.hs
delete mode 100644 project_template/src/Main.hs
delete mode 100644 src/Snap/StarterTH.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 6cfc5bb3273a7f2e8842f21726f2550424cf46a9
Merge: fdb4a77 ea5fc3f
Author: Gregory Collins <[email protected]>
Date: Wed May 26 21:30:29 2010 -0400
Merge branch 'master' of git.snapframework.com:snap-core
commit fdb4a77141e6acd1d63057c3917c9c1b062efafb
Author: Gregory Collins <[email protected]>
Date: Wed May 26 21:29:53 2010 -0400
Temporarily revert "Expand the template app and moved its code out of
Starter.hs to a"
This reverts commit 6d3cea8c845ea26decb94ac9f58a88ed4538d8f0. (So we can
apply
jystic's windows patch)
diff --git a/.ghci b/.ghci
deleted file mode 100644
index 864acfc..0000000
--- a/.ghci
+++ /dev/null
@@ -1,7 +0,0 @@
-:set -XOverloadedStrings
-:set -XTemplateHaskell
-:set -XNoMonomorphismRestriction
-:set -Wall
-:set -isrc
-:set -itest/suite
-:set -hide-package mtl
diff --git a/project_template/foo.cabal b/project_template/foo.cabal
deleted file mode 100644
index 0fdaa77..0000000
--- a/project_template/foo.cabal
+++ /dev/null
@@ -1,37 +0,0 @@
-Name: projname
-Version: 0.1
-Synopsis: Project Synopsis Here
-Description: Project Description Here
-License: AllRightsReserved
-Author: Author
-Maintainer: [email protected]
-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,
- heist >= 0.1 && <0.2,
- hexpat == 0.16,
- xhtml-combinators,
- unix,
- text,
- 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
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/project_template/src/Main.hs b/project_template/src/Main.hs
deleted file mode 100644
index 4699c3f..0000000
--- a/project_template/src/Main.hs
+++ /dev/null
@@ -1,34 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module Main where
-
-import Control.Applicative
-import Snap.Types
-import Snap.Util.FileServe
-
-import Common
-
-config :: AppConfig
-config = AppConfig {
- templateDir = "templates",
- 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
-
diff --git a/snap-core.cabal b/snap-core.cabal
index 5c62df3..080c406 100644
--- a/snap-core.cabal
+++ b/snap-core.cabal
@@ -168,7 +168,6 @@ Executable snap
cereal >= 0.2 && < 0.3,
containers,
directory,
- directory-tree,
dlist >= 0.5 && < 0.6,
filepath,
haskell98,
@@ -176,7 +175,6 @@ Executable snap
monads-fd,
old-locale,
old-time,
- template-haskell,
text >= 0.7.1 && <0.8,
time,
transformers,
diff --git a/src/Snap/Iteratee.hs b/src/Snap/Iteratee.hs
index 1b5820e..dcc6a0d 100644
--- a/src/Snap/Iteratee.hs
+++ b/src/Snap/Iteratee.hs
@@ -168,7 +168,7 @@ unsafeBufferIteratee iteratee = do
runIter iter $ Chunk $ WrapBS s
copy c@(EOF _) = c
- copy (Chunk (WrapBS s)) = Chunk $ WrapBS $ S.copy s
+ copy c@(Chunk (WrapBS s)) = Chunk $ WrapBS $ S.copy s
f _ _ iter ch@(EOF (Just _)) = runIter iter ch
diff --git a/src/Snap/Starter.hs b/src/Snap/Starter.hs
index 2e49d73..22d829b 100644
--- a/src/Snap/Starter.hs
+++ b/src/Snap/Starter.hs
@@ -1,21 +1,12 @@
-{-# LANGUAGE TemplateHaskell #-}
module Main where
------------------------------------------------------------------------------
-import Data.List
-import qualified Data.Text as T
import System
import System.Directory
+import System.Console.GetOpt
import System.FilePath.Posix
------------------------------------------------------------------------------
-import Snap.StarterTH
-
-
-------------------------------------------------------------------------------
--- Creates a value tDir :: ([String], [(String, String)])
-$(buildData "tDir")
-
------------------------------------------------------------------------------
usage :: String
@@ -35,26 +26,42 @@ data InitFlag = InitBareBones
deriving (Show, Eq)
-setup :: String -> IO ()
-setup projName = do
- mapM createDirectory (fst tDir)
- mapM_ write (snd tDir)
+------------------------------------------------------------------------------
+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
- write (f,c) =
- if isSuffixOf "foo.cabal" f
- then writeFile (projName++".cabal") (insertProjName $ T.pack c)
- else writeFile f c
- insertProjName c = T.unpack $ T.replace
- (T.pack "projname")
- (T.pack projName) c
+ initUsage = unlines
+ ["Usage:"
+ ,""
+ ," snap init"
+ ,""
+ ," -b --barebones Depend only on -core and -server"
+ ," -h --help Print this message"
+ ]
-------------------------------------------------------------------------------
-initProject :: IO ()
-initProject = do
- cur <- getCurrentDirectory
- let dirs = splitDirectories cur
- projName = last dirs
- setup projName
+ 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
+ writeFile (projName++".cabal") (cabalFile projName isBareBones)
+ createDirectory "src"
+ writeFile "src/Main.hs" (mainFile isBareBones)
------------------------------------------------------------------------------
@@ -62,7 +69,72 @@ main :: IO ()
main = do
args <- getArgs
case args of
- ("init":_) -> initProject
- _ -> do putStrLn usage
- exitFailure
+ ("init":args') -> initProject args'
+ _ -> do putStrLn usage
+ exitFailure
+
+
+------------------------------------------------------------------------------
+cabalFile :: String -> Bool -> String
+cabalFile projName isBareBones = unlines $
+ ["Name: "++projName
+ ,"Version: 0.1"
+ ,"Synopsis: Project Synopsis Here"
+ ,"Description: Project Description Here"
+ ,"License: AllRightsReserved"
+ ,"Author: Author"
+ ,"Maintainer: [email protected]"
+ ,"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,"
+ ] ++ (if isBareBones then [] else [" heist >= 0.1 && <0.2,"]) ++
+ [" filepath >= 1.1 && <1.2"
+ ,""
+ ," ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded
-fno-warn-unused-imports"
+ ]
+
+
+------------------------------------------------------------------------------
+mainFile :: Bool -> String
+mainFile isBareBones = unlines $
+ ["{-# LANGUAGE OverloadedStrings #-}"
+ ,"module Main where"
+ ,""
+ ,"import System"
+ ,"import Control.Applicative"
+ ,"import Control.Monad.Trans"
+ ,"import Snap.Http.Server"
+ ,"import Snap.Types"
+ ,"import Snap.Util.FileServe"
+ ] ++ (if isBareBones then [] else ["import
Text.Templating.Heist"]) ++
+ [""
+ ,"site :: Snap ()"
+ ,"site ="
+ ," ifTop (writeBS \"hello world\") <|>"
+ ," fileServe \".\""
+ ,""
+ ,"main :: IO ()"
+ ,"main = do"
+ ," args <- getArgs"
+ ," let port = case args of"
+ ," [] -> 8000"
+ ," p:_ -> read p"
+ ," httpServe \"*\" port \"myserver\""
+ ," (Just \"access.log\")"
+ ," (Just \"error.log\")"
+ ," site"
+ ]
diff --git a/src/Snap/StarterTH.hs b/src/Snap/StarterTH.hs
deleted file mode 100644
index 04d9091..0000000
--- a/src/Snap/StarterTH.hs
+++ /dev/null
@@ -1,55 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-module Snap.StarterTH where
-
-------------------------------------------------------------------------------
-import qualified Data.Foldable as F
-import Data.List
-import Language.Haskell.TH
-import System.Directory.Tree
-------------------------------------------------------------------------------
-
-
-------------------------------------------------------------------------------
--- Convenience types
-type FileData = (String, String)
-type DirData = String
-
-
-------------------------------------------------------------------------------
--- Gets all the directorys in a DirTree
-getDirs :: [String] -> DirTree a -> [String]
-getDirs prefix (Dir n c) = (intercalate "/" (reverse (n:prefix))) : concatMap
(getDirs (n:prefix)) c
-getDirs _ (File _ _) = []
-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 dir = do
- d <- readDirectory $ dir++"/."
- let ps = zipPaths $ "" :/ (free d)
- fd = F.foldr (:) [] ps
- dirs = tail $ getDirs [] $ free d
- return $ (dirs, fd)
-
-
-------------------------------------------------------------------------------
--- Calls readTree and returns it's value in a quasiquote.
-dirQ :: Q Exp
-dirQ = do
- d <- runIO $ readTree "project_template"
- runQ [| d |]
-
-
-------------------------------------------------------------------------------
--- Creates a declaration assigning the specified name the value returned by
--- dirQ.
-buildData :: String -> Q [Dec]
-buildData dirName = do
- v <- valD (varP (mkName dirName))
- (normalB dirQ)
- []
- return [v]
-
diff --git a/src/Snap/Util/GZip.hs b/src/Snap/Util/GZip.hs
index 3c26c54..42c1de2 100644
--- a/src/Snap/Util/GZip.hs
+++ b/src/Snap/Util/GZip.hs
@@ -300,7 +300,7 @@ acceptParser = do
coding = string "*" <|> takeWhile isCodingChar
- isCodingChar ch = isAlpha_ascii ch || ch == '-'
+ isCodingChar c = isAlpha_ascii c || c == '-'
float = takeWhile isDigit >>
option () (char '.' >> takeWhile isDigit >> pure ())
-----------------------------------------------------------------------
hooks/post-receive
--
snap-core
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
