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".
The branch, master has been updated
via 7e8c42be19f0c6b5f19fc70b748e4ab436cceb48 (commit)
via 6acf09588a5aa2a4a9eed819f3ffddbdc8ac716c (commit)
from b22027fe45175e6f15b0f010c0091a8346f45e4d (commit)
Summary of changes:
project_template/barebones/foo.cabal | 35 +++++
project_template/barebones/src/Main.hs | 22 +++
project_template/barebones/src/Server.hs | 111 ++++++++++++++++
project_template/default/foo.cabal | 37 +++++
project_template/default/src/Glue.hs | 46 +++++++
project_template/default/src/Main.hs | 30 ++++
project_template/default/src/Server.hs | 111 ++++++++++++++++
project_template/hint/resources/static/favicon.ico | Bin 0 -> 32038 bytes
snap.cabal | 51 +++++++
src/Snap/Loader/Hint.hs | 140 ++++++++++++++++++++
src/Snap/Loader/Static.hs | 18 +++
src/Snap/Starter.hs | 97 ++++++++++++++
src/Snap/StarterTH.hs | 55 ++++++++
13 files changed, 753 insertions(+), 0 deletions(-)
create mode 100644 project_template/barebones/foo.cabal
create mode 100644 project_template/barebones/src/Main.hs
create mode 100644 project_template/barebones/src/Server.hs
create mode 100644 project_template/default/foo.cabal
create mode 100644 project_template/default/src/Glue.hs
create mode 100644 project_template/default/src/Main.hs
create mode 100644 project_template/default/src/Server.hs
create mode 100644 project_template/hint/foo.cabal
create mode 100644 project_template/hint/log/access.log
create mode 100644 project_template/hint/log/error.log
create mode 100644 project_template/hint/resources/static/favicon.ico
create mode 100644 project_template/hint/resources/static/screen.css
create mode 100644 project_template/hint/resources/templates/index.tpl
create mode 100644 project_template/hint/src/Config.hs
create mode 100644 project_template/hint/src/Main.hs
create mode 100644 project_template/hint/src/Site.hs
create mode 100644 snap.cabal
create mode 100644 src/Snap/Loader/Hint.hs
create mode 100644 src/Snap/Loader/Static.hs
create mode 100644 src/Snap/Starter.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 7e8c42be19f0c6b5f19fc70b748e4ab436cceb48
Author: Carl Howells <[email protected]>
Date: Mon Jun 21 01:35:19 2010 -0700
Basic functionality in place for doing hint loading
diff --git a/project_template/barebones/foo.cabal
b/project_template/barebones/foo.cabal
new file mode 100644
index 0000000..a61c523
--- /dev/null
+++ b/project_template/barebones/foo.cabal
@@ -0,0 +1,35 @@
+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,
+ xhtml-combinators,
+ unix,
+ text,
+ containers,
+ MonadCatchIO-transformers,
+ filepath >= 1.1 && <1.2
+
+ if impl(ghc >= 6.12.0)
+ ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
+ -fno-warn-unused-do-bind
+ else
+ ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
diff --git a/project_template/barebones/src/Main.hs
b/project_template/barebones/src/Main.hs
new file mode 100644
index 0000000..1c72738
--- /dev/null
+++ b/project_template/barebones/src/Main.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+import Control.Applicative
+import Snap.Types
+import Snap.Util.FileServe
+
+import Server
+
+main :: IO ()
+main = quickServer $
+ 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/project_template/barebones/src/Server.hs
b/project_template/barebones/src/Server.hs
new file mode 100644
index 0000000..2dd625b
--- /dev/null
+++ b/project_template/barebones/src/Server.hs
@@ -0,0 +1,111 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Server
+ ( ServerConfig(..)
+ , emptyServerConfig
+ , commandLineConfig
+ , server
+ , quickServer
+ ) where
+import qualified Data.ByteString.Char8 as B
+import Data.ByteString.Char8 (ByteString)
+import Data.Char
+import Control.Concurrent
+import Control.Exception (SomeException)
+import Control.Monad.CatchIO
+import qualified Data.Text as T
+import Prelude hiding (catch)
+import Snap.Http.Server
+import Snap.Types
+import Snap.Util.GZip
+import System hiding (getEnv)
+import System.Posix.Env
+import qualified Text.XHtmlCombinators.Escape as XH
+
+
+data ServerConfig = ServerConfig
+ { locale :: String
+ , interface :: ByteString
+ , port :: Int
+ , hostname :: ByteString
+ , accessLog :: Maybe FilePath
+ , errorLog :: Maybe FilePath
+ , compression :: Bool
+ , error500Handler :: SomeException -> Snap ()
+ }
+
+
+emptyServerConfig :: ServerConfig
+emptyServerConfig = ServerConfig
+ { locale = "en_US"
+ , interface = "0.0.0.0"
+ , port = 8000
+ , hostname = "myserver"
+ , accessLog = Just "access.log"
+ , errorLog = Just "error.log"
+ , compression = True
+ , error500Handler = \e -> do
+ let t = T.pack $ show e
+ r = setContentType "text/html; charset=utf-8" $
+ setResponseStatus 500 "Internal Server Error" emptyResponse
+ 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>"
+ }
+
+
+commandLineConfig :: IO ServerConfig
+commandLineConfig = do
+ args <- getArgs
+ let conf = case args of
+ [] -> emptyServerConfig
+ (port':_) -> emptyServerConfig { port = read port' }
+ locale' <- getEnv "LANG"
+ return $ case locale' of
+ Nothing -> conf
+ Just l -> conf {locale = takeWhile (\c -> isAlpha c || c == '_') l}
+
+server :: ServerConfig -> Snap () -> IO ()
+server config handler = do
+ putStrLn $ "Listening on " ++ (B.unpack $ interface config)
+ ++ ":" ++ show (port config)
+ setUTF8Locale (locale config)
+ try $ httpServe
+ (interface config)
+ (port config)
+ (hostname config)
+ (accessLog config)
+ (errorLog config)
+ (catch500 $ compress $ handler)
+ :: IO (Either SomeException ())
+ threadDelay 1000000
+ putStrLn "Shutting down"
+ where
+ catch500 = (`catch` (error500Handler config))
+ compress = if compression config then withCompression else id
+
+
+quickServer :: Snap () -> IO ()
+quickServer = (commandLineConfig >>=) . flip server
+
+
+setUTF8Locale :: String -> IO ()
+setUTF8Locale locale' = do
+ mapM_ (\k -> setEnv k (locale' ++ ".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" ]
diff --git a/project_template/default/foo.cabal
b/project_template/default/foo.cabal
new file mode 100644
index 0000000..d3e3b7b
--- /dev/null
+++ b/project_template/default/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.2.2 && <0.3,
+ hexpat == 0.16,
+ xhtml-combinators,
+ unix,
+ text,
+ containers,
+ MonadCatchIO-transformers,
+ filepath >= 1.1 && <1.2
+
+ if impl(ghc >= 6.12.0)
+ ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
+ -fno-warn-unused-do-bind
+ else
+ ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
diff --git a/project_template/default/src/Glue.hs
b/project_template/default/src/Glue.hs
new file mode 100644
index 0000000..e6a789c
--- /dev/null
+++ b/project_template/default/src/Glue.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Glue
+ ( templateHandler
+ , defaultReloadHandler
+ , templateServe
+ , render
+ ) where
+
+import Control.Applicative
+import Control.Monad
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Prelude hiding (catch)
+import Snap.Types hiding (dir)
+import Snap.Util.FileServe
+import Text.Templating.Heist
+import Text.Templating.Heist.TemplateDirectory
+
+
+templateHandler :: TemplateDirectory Snap
+ -> (TemplateDirectory Snap -> Snap ())
+ -> (TemplateState Snap -> Snap ())
+ -> Snap ()
+templateHandler td reload f = reload td <|> (f =<< getDirectoryTS td)
+
+
+defaultReloadHandler :: TemplateDirectory Snap -> Snap ()
+defaultReloadHandler td = path "admin/reload" $ do
+ e <- reloadTemplateDirectory td
+ modifyResponse $ setContentType "text/plain; charset=utf-8"
+ writeBS . B.pack $ either id (const "Templates loaded successfully.") e
+
+
+render :: TemplateState Snap -> ByteString -> Snap ()
+render ts template = do
+ bytes <- renderTemplate ts template
+ flip (maybe pass) bytes $ \x -> do
+ modifyResponse $ setContentType "text/html; charset=utf-8"
+ writeBS x
+
+
+templateServe :: TemplateState Snap -> Snap ()
+templateServe ts = ifTop (render ts "index") <|> do
+ path' <- getSafePath
+ when (head path' == '_') pass
+ render ts $ B.pack path'
diff --git a/project_template/default/src/Main.hs
b/project_template/default/src/Main.hs
new file mode 100644
index 0000000..3254b3b
--- /dev/null
+++ b/project_template/default/src/Main.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+import Control.Applicative
+import Snap.Types
+import Snap.Util.FileServe
+import Text.Templating.Heist
+import Text.Templating.Heist.TemplateDirectory
+
+import Glue
+import Server
+
+
+main :: IO ()
+main = do
+ td <- newTemplateDirectory' "templates" emptyTemplateState
+ quickServer $ templateHandler td defaultReloadHandler $ \ts ->
+ ifTop (writeBS "hello world") <|>
+ route [ ("foo", writeBS "bar")
+ , ("echo/:echoparam", echoHandler)
+ ] <|>
+ templateServe ts <|>
+ dir "static" (fileServe ".")
+
+
+echoHandler :: Snap ()
+echoHandler = do
+ param <- getParam "echoparam"
+ maybe (writeBS "must specify echo/param in URL")
+ writeBS param
diff --git a/project_template/default/src/Server.hs
b/project_template/default/src/Server.hs
new file mode 100644
index 0000000..2dd625b
--- /dev/null
+++ b/project_template/default/src/Server.hs
@@ -0,0 +1,111 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Server
+ ( ServerConfig(..)
+ , emptyServerConfig
+ , commandLineConfig
+ , server
+ , quickServer
+ ) where
+import qualified Data.ByteString.Char8 as B
+import Data.ByteString.Char8 (ByteString)
+import Data.Char
+import Control.Concurrent
+import Control.Exception (SomeException)
+import Control.Monad.CatchIO
+import qualified Data.Text as T
+import Prelude hiding (catch)
+import Snap.Http.Server
+import Snap.Types
+import Snap.Util.GZip
+import System hiding (getEnv)
+import System.Posix.Env
+import qualified Text.XHtmlCombinators.Escape as XH
+
+
+data ServerConfig = ServerConfig
+ { locale :: String
+ , interface :: ByteString
+ , port :: Int
+ , hostname :: ByteString
+ , accessLog :: Maybe FilePath
+ , errorLog :: Maybe FilePath
+ , compression :: Bool
+ , error500Handler :: SomeException -> Snap ()
+ }
+
+
+emptyServerConfig :: ServerConfig
+emptyServerConfig = ServerConfig
+ { locale = "en_US"
+ , interface = "0.0.0.0"
+ , port = 8000
+ , hostname = "myserver"
+ , accessLog = Just "access.log"
+ , errorLog = Just "error.log"
+ , compression = True
+ , error500Handler = \e -> do
+ let t = T.pack $ show e
+ r = setContentType "text/html; charset=utf-8" $
+ setResponseStatus 500 "Internal Server Error" emptyResponse
+ 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>"
+ }
+
+
+commandLineConfig :: IO ServerConfig
+commandLineConfig = do
+ args <- getArgs
+ let conf = case args of
+ [] -> emptyServerConfig
+ (port':_) -> emptyServerConfig { port = read port' }
+ locale' <- getEnv "LANG"
+ return $ case locale' of
+ Nothing -> conf
+ Just l -> conf {locale = takeWhile (\c -> isAlpha c || c == '_') l}
+
+server :: ServerConfig -> Snap () -> IO ()
+server config handler = do
+ putStrLn $ "Listening on " ++ (B.unpack $ interface config)
+ ++ ":" ++ show (port config)
+ setUTF8Locale (locale config)
+ try $ httpServe
+ (interface config)
+ (port config)
+ (hostname config)
+ (accessLog config)
+ (errorLog config)
+ (catch500 $ compress $ handler)
+ :: IO (Either SomeException ())
+ threadDelay 1000000
+ putStrLn "Shutting down"
+ where
+ catch500 = (`catch` (error500Handler config))
+ compress = if compression config then withCompression else id
+
+
+quickServer :: Snap () -> IO ()
+quickServer = (commandLineConfig >>=) . flip server
+
+
+setUTF8Locale :: String -> IO ()
+setUTF8Locale locale' = do
+ mapM_ (\k -> setEnv k (locale' ++ ".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" ]
diff --git a/project_template/hint/foo.cabal b/project_template/hint/foo.cabal
new file mode 100644
index 0000000..e69de29
diff --git a/project_template/hint/log/access.log
b/project_template/hint/log/access.log
new file mode 100644
index 0000000..e69de29
diff --git a/project_template/hint/log/error.log
b/project_template/hint/log/error.log
new file mode 100644
index 0000000..e69de29
diff --git a/project_template/hint/resources/static/favicon.ico
b/project_template/hint/resources/static/favicon.ico
new file mode 100644
index 0000000..af01ed3
Binary files /dev/null and b/project_template/hint/resources/static/favicon.ico
differ
diff --git a/project_template/hint/resources/static/screen.css
b/project_template/hint/resources/static/screen.css
new file mode 100644
index 0000000..e69de29
diff --git a/project_template/hint/resources/templates/index.tpl
b/project_template/hint/resources/templates/index.tpl
new file mode 100644
index 0000000..e69de29
diff --git a/project_template/hint/src/Config.hs
b/project_template/hint/src/Config.hs
new file mode 100644
index 0000000..e69de29
diff --git a/project_template/hint/src/Main.hs
b/project_template/hint/src/Main.hs
new file mode 100644
index 0000000..e69de29
diff --git a/project_template/hint/src/Site.hs
b/project_template/hint/src/Site.hs
new file mode 100644
index 0000000..e69de29
diff --git a/src/Snap/Starter.hs b/src/Snap/Starter.hs
new file mode 100644
index 0000000..bddb339
--- /dev/null
+++ b/src/Snap/Starter.hs
@@ -0,0 +1,97 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Snap.Starter where
+
+------------------------------------------------------------------------------
+import Data.List
+import qualified Data.Text as T
+import System
+import System.Directory
+import System.Console.GetOpt
+import System.FilePath
+------------------------------------------------------------------------------
+
+import Snap.StarterTH
+
+
+------------------------------------------------------------------------------
+-- Creates a value tDir :: ([String], [(String, String)])
+$(buildData "tDirDefault" "default")
+$(buildData "tDirBareBones" "barebones")
+$(buildData "tDirHint" "hint")
+
+------------------------------------------------------------------------------
+usage :: String
+usage = unlines
+ ["Usage:"
+ ,""
+ ," snap <action>"
+ ,""
+ ," <action> can be one of:"
+ ," init - create a new project directory structure in the current
directory"
+ ]
+
+
+------------------------------------------------------------------------------
+data InitFlag = InitBareBones
+ | InitHelp
+ deriving (Show, Eq)
+
+
+setup :: String -> ([FilePath], [(String, String)]) -> IO ()
+setup projName tDir = do
+ mapM createDirectory (fst tDir)
+ mapM_ write (snd tDir)
+ 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
+
+------------------------------------------------------------------------------
+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)
+
+
+------------------------------------------------------------------------------
+main :: IO ()
+main = do
+ args <- getArgs
+ case args of
+ ("init":args') -> initProject args'
+ _ -> do putStrLn usage
+ exitFailure
+
diff --git a/src/Snap/StarterTH.hs b/src/Snap/StarterTH.hs
new file mode 100644
index 0000000..17f8cce
--- /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 = FilePath
+
+
+------------------------------------------------------------------------------
+-- Gets all the directorys in a DirTree
+getDirs :: [FilePath] -> DirTree a -> [FilePath]
+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 :: FilePath -> 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 :: 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 -> FilePath -> Q [Dec]
+buildData dirName tplDir = do
+ v <- valD (varP (mkName dirName))
+ (normalB $ dirQ tplDir)
+ []
+ return [v]
+
commit 6acf09588a5aa2a4a9eed819f3ffddbdc8ac716c
Author: Carl Howells <[email protected]>
Date: Sat Jun 19 03:57:06 2010 -0700
loader modules to compiling state
diff --git a/snap.cabal b/snap.cabal
new file mode 100644
index 0000000..d8b2dfe
--- /dev/null
+++ b/snap.cabal
@@ -0,0 +1,51 @@
+name: snap
+version: 0.3
+synopsis: Snap: A Haskell Web Framework (Core)
+
+description:
+ This is the first developer prerelease of the Snap framework. Snap is a
+ simple and fast web development framework and server written in Haskell. For
+ more information or to download the latest version, you can visit the Snap
+ project website at <http://snapframework.com/>.
+ .
+
+license: BSD3
+license-file: LICENSE
+author: James Sanders, Shu-yu Guo, Gregory Collins, Doug Beardsley
+maintainer: [email protected]
+build-type: Simple
+cabal-version: >= 1.6
+homepage: http://snapframework.com/
+category: Web
+
+extra-source-files:
+ CONTRIBUTORS,
+ LICENSE,
+ README.md,
+ README.SNAP.md
+
+Library
+ hs-source-dirs: src
+
+ exposed-modules:
+ Snap.Loader.Static,
+ Snap.Loader.Hint
+
+ build-depends:
+ base >= 4 && < 5,
+ bytestring >= 0.9.1 && < 0.10,
+ directory >= 1.0.0.0 && < 1.1,
+ filepath >= 1.0 && < 1.2,
+ monads-fd >= 0.1 && < 0.2,
+ snap-core >= 0.2.7 && < 0.3,
+ heist >= 0.2.1 && < 0.3,
+ hint >= 0.3.2 && < 0.4,
+ template-haskell >= 2.3 && < 2.5,
+ time >= 1.0 && < 1.3
+
+ 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/src/Snap/Loader/Hint.hs b/src/Snap/Loader/Hint.hs
new file mode 100644
index 0000000..cb5683b
--- /dev/null
+++ b/src/Snap/Loader/Hint.hs
@@ -0,0 +1,140 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Snap.Loader.Hint where
+
+------------------------------------------------------------------------------
+import qualified Data.ByteString.Char8 as S
+
+import Data.List (nub)
+
+import Control.Concurrent (forkIO)
+import Control.Concurrent.MVar
+import Control.Monad (when)
+import Control.Monad.Trans (liftIO)
+
+import Data.Maybe (catMaybes)
+import Data.Time.Clock
+
+import Language.Haskell.Interpreter hiding (lift, liftIO)
+import Language.Haskell.Interpreter.Unsafe (unsafeSetGhcOption)
+
+import Language.Haskell.TH.Syntax
+
+import System.Directory (getCurrentDirectory)
+import System.FilePath ((</>))
+
+------------------------------------------------------------------------------
+import Snap.Types
+
+
+
+------------------------------------------------------------------------------
+-- | XXX
+-- Assumes being spliced into the same source tree as the action to
+-- dynamically load is located in
+-- Assumes mtl is the only package installed with a conflicting
+-- Control.Monad.Trans
+loadSnapTH :: Name -> Name -> Q Exp
+loadSnapTH initialize action = do
+ loc <- location
+ cwd <- runIO getCurrentDirectory
+
+ let initMod = nameModule initialize
+ initBase = nameBase initialize
+ actMod = nameModule action
+ actBase = nameBase action
+
+ lf = length . loc_filename $ loc
+ lm = length . loc_module $ loc
+ relSrc = if lf > lm + 4
+ then take (lf - (lm + 4)) $ loc_filename loc
+ else "."
+ src = cwd </> relSrc
+ str = "liftIO " ++ initBase ++ " >>= " ++ actBase
+ modules = catMaybes [initMod, actMod]
+ opts = [ "-hide-package=mtl" ] :: [String]
+
+ hintSnapE = VarE 'hintSnap
+
+ optsE <- lift opts
+ srcE <- lift src
+ modulesE <- lift modules
+ strE <- lift str
+
+ return $ foldl AppE hintSnapE [optsE, srcE, modulesE, strE]
+
+
+------------------------------------------------------------------------------
+-- | XXX
+hintSnap :: [String] -> String -> [String] -> String -> IO (Snap ())
+hintSnap opts sPath mNames action = do
+ let interpreter = do
+ mapM_ unsafeSetGhcOption opts
+ set [ searchPath := [sPath] ]
+ loadModules . nub $ mNames
+ let allMods = "Prelude":"Snap.Types":"Control.Monad.Trans":mNames
+ setImports . nub $ allMods
+ interpret action (as :: Snap ())
+
+ loadAction <- protectedActionEvaluator 3 $ runInterpreter interpreter
+
+ return $ do
+ eSnap <- liftIO loadAction
+ case eSnap of
+ Left err -> do
+ let msg = format err
+ len = fromIntegral $ S.length msg
+ modifyResponse $ setContentType "text/plain; charset=utf-8"
+ . setResponseStatus 500 "Internal Server Error"
+ . setContentLength len
+ writeBS msg
+
+ Right handler -> handler
+
+
+------------------------------------------------------------------------------
+-- |
+format :: InterpreterError -> S.ByteString
+format (UnknownError e) =
+ S.append "Unknown interpreter error:\r\n\r\n" $ S.pack e
+
+format (NotAllowed e) =
+ S.append "Interpreter action not allowed:\r\n\r\n" $ S.pack e
+
+format (GhcException e) =
+ S.append "GHC error:\r\n\r\n" $ S.pack e
+
+format (WontCompile errs) =
+ let formatted = S.intercalate "\r\n" . map S.pack . nub . map errMsg $ errs
+ in S.append "Compile errors:\r\n\r\n" formatted
+
+
+------------------------------------------------------------------------------
+-- | XXX
+protectedActionEvaluator :: NominalDiffTime -> IO a -> IO (IO a)
+protectedActionEvaluator minReEval action = do
+ readerContainer <- newMVar []
+ resultContainer <- newMVar Nothing
+ return $ do
+ existingResult <- readMVar resultContainer
+ now <- getCurrentTime
+
+ case existingResult of
+ Just (val, ts) | diffUTCTime now ts < minReEval -> return val
+ _ -> do
+ reader <- newEmptyMVar
+ readers <- takeMVar readerContainer
+
+ when (null readers) $ do
+ forkIO $ do
+ result <- action
+ allReaders <- takeMVar readerContainer
+ finishTime <- getCurrentTime
+ swapMVar resultContainer $ Just (result, finishTime)
+ putMVar readerContainer []
+ mapM_ (flip putMVar result) allReaders
+ return ()
+
+ putMVar readerContainer $ reader : readers
+ takeMVar reader
diff --git a/src/Snap/Loader/Static.hs b/src/Snap/Loader/Static.hs
new file mode 100644
index 0000000..b3ac8b1
--- /dev/null
+++ b/src/Snap/Loader/Static.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Snap.Loader.Static where
+
+------------------------------------------------------------------------------
+import Language.Haskell.TH.Syntax
+
+
+------------------------------------------------------------------------------
+-- | XXX
+
+loadSnapTH :: Name -> Name -> Q Exp
+loadSnapTH init action = do
+ let initE = VarE init
+ actE = VarE action
+ fmapE = VarE 'fmap
+ simpleLoad = foldl AppE fmapE [actE, initE]
+ return simpleLoad
-----------------------------------------------------------------------
hooks/post-receive
--
snap
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
