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 6d3cea8c845ea26decb94ac9f58a88ed4538d8f0 (commit)
from a45e44a9c9095cfa266647cd805e7301a9b06aab (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, 319 insertions(+), 105 deletions(-)
create mode 100644 .ghci
create mode 100644 project_template/foo.cabal
create mode 100644 project_template/src/Common.hs
create mode 100644 project_template/src/Main.hs
create 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 6d3cea8c845ea26decb94ac9f58a88ed4538d8f0
Author: Mighty Byte <[email protected]>
Date: Wed May 26 21:12:43 2010 -0400
Expand the template app and moved its code out of Starter.hs to a
standalone directory. Also squashed some warnings.
diff --git a/.ghci b/.ghci
new file mode 100644
index 0000000..864acfc
--- /dev/null
+++ b/.ghci
@@ -0,0 +1,7 @@
+: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
new file mode 100644
index 0000000..0fdaa77
--- /dev/null
+++ b/project_template/foo.cabal
@@ -0,0 +1,37 @@
+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
new file mode 100644
index 0000000..42c05c0
--- /dev/null
+++ b/project_template/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/src/Main.hs
new file mode 100644
index 0000000..4699c3f
--- /dev/null
+++ b/project_template/src/Main.hs
@@ -0,0 +1,34 @@
+{-# 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 080c406..5c62df3 100644
--- a/snap-core.cabal
+++ b/snap-core.cabal
@@ -168,6 +168,7 @@ Executable snap
cereal >= 0.2 && < 0.3,
containers,
directory,
+ directory-tree,
dlist >= 0.5 && < 0.6,
filepath,
haskell98,
@@ -175,6 +176,7 @@ 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 dcc6a0d..1b5820e 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 c@(Chunk (WrapBS s)) = Chunk $ WrapBS $ S.copy s
+ copy (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 22d829b..2e49d73 100644
--- a/src/Snap/Starter.hs
+++ b/src/Snap/Starter.hs
@@ -1,12 +1,21 @@
+{-# 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
@@ -26,42 +35,26 @@ data InitFlag = InitBareBones
deriving (Show, Eq)
-------------------------------------------------------------------------------
-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
+setup :: String -> IO ()
+setup projName = do
+ mapM createDirectory (fst tDir)
+ mapM_ write (snd tDir)
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"
- ]
+ 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
- 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)
+------------------------------------------------------------------------------
+initProject :: IO ()
+initProject = do
+ cur <- getCurrentDirectory
+ let dirs = splitDirectories cur
+ projName = last dirs
+ setup projName
------------------------------------------------------------------------------
@@ -69,72 +62,7 @@ main :: IO ()
main = do
args <- getArgs
case args of
- ("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"
- ]
+ ("init":_) -> initProject
+ _ -> do putStrLn usage
+ exitFailure
diff --git a/src/Snap/StarterTH.hs b/src/Snap/StarterTH.hs
new file mode 100644
index 0000000..04d9091
--- /dev/null
+++ b/src/Snap/StarterTH.hs
@@ -0,0 +1,55 @@
+{-# 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 42c1de2..3c26c54 100644
--- a/src/Snap/Util/GZip.hs
+++ b/src/Snap/Util/GZip.hs
@@ -300,7 +300,7 @@ acceptParser = do
coding = string "*" <|> takeWhile isCodingChar
- isCodingChar c = isAlpha_ascii c || c == '-'
+ isCodingChar ch = isAlpha_ascii ch || ch == '-'
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
