snap-core 0.2.4 → 0.2.5
raw patch · 8 files changed
+411/−1 lines, 8 files
Files
- project_template/barebones/foo.cabal +33/−0
- project_template/barebones/src/Common.hs +59/−0
- project_template/barebones/src/Main.hs +33/−0
- project_template/default/foo.cabal +37/−0
- project_template/default/src/Common.hs +151/−0
- project_template/default/src/Main.hs +34/−0
- snap-core.cabal +9/−1
- src/Snap/StarterTH.hs +55/−0
+ project_template/barebones/foo.cabal view
@@ -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
+ project_template/barebones/src/Common.hs view
@@ -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 ()+
+ project_template/barebones/src/Main.hs view
@@ -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+
+ project_template/default/foo.cabal view
@@ -0,0 +1,37 @@+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,+ 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
+ project_template/default/src/Common.hs view
@@ -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 ()+
+ project_template/default/src/Main.hs view
@@ -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+
snap-core.cabal view
@@ -1,5 +1,5 @@ name: snap-core-version: 0.2.4+version: 0.2.5 synopsis: Snap: A Haskell Web Framework (Core) description:@@ -73,6 +73,12 @@ extra/logo.gif, haddock.sh, LICENSE,+ project_template/barebones/foo.cabal,+ project_template/barebones/src/Common.hs,+ project_template/barebones/src/Main.hs,+ project_template/default/foo.cabal,+ project_template/default/src/Common.hs,+ project_template/default/src/Main.hs, README.md, README.SNAP.md, Setup.hs,@@ -167,6 +173,8 @@ Executable snap hs-source-dirs: src main-is: Snap/Starter.hs++ other-modules: Snap.StarterTH build-depends: attoparsec >= 0.8.0.2 && < 0.9,
+ src/Snap/StarterTH.hs view
@@ -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]+