Permalink
Browse files

mkdir snapfib; cd snapfib; snap init

  • Loading branch information...
ujihisa committed Dec 6, 2010
0 parents commit 3037ba6de8ec7bfb15f76912019c74c35a1a6b75
Showing with 224 additions and 0 deletions.
  1. +37 −0 snapfib.cabal
  2. +46 −0 src/Glue.hs
  3. +30 −0 src/Main.hs
  4. +111 −0 src/Server.hs
@@ -0,0 +1,37 @@
+Name: snapfib
+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 snapfib
+ 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.4 && <0.3,
+ hexpat >= 0.19 && <0.20,
+ 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
@@ -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'
@@ -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
@@ -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" ]

0 comments on commit 3037ba6

Please sign in to comment.