Permalink
Browse files

Update to use 0.6 snaplets

  • Loading branch information...
mightybyte committed Oct 19, 2011
1 parent 4e5b201 commit 2c9aacc3c1ef118348554db175e6a79d6aae323a
View
@@ -19,15 +19,17 @@ Executable snap-website
base >= 4,
bytestring,
containers,
+ data-lens-template >= 2.1 && < 2.2,
directory,
filepath,
haskell98,
- heist >= 0.5 && <0.6,
+ heist >= 0.6 && < 0.7,
MonadCatchIO-transformers >= 0.2 && < 0.3,
mtl >= 2 && <3,
process,
- snap-core >= 0.5 && <0.6,
- snap-server >= 0.5 && <0.6,
+ snap >= 0.6 && <0.7,
+ snap-core >= 0.6 && <0.7,
+ snap-server >= 0.6 && <0.7,
snap-static-pages >= 0.1 && <1.0,
text,
time,
View
@@ -1,153 +1,79 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
module Main where
-import Data.ByteString.Char8 (ByteString)
+import Control.Applicative
+import Control.Exception (SomeException)
+import Control.Monad
+import Control.Monad.CatchIO
+import Control.Monad.Trans
import qualified Data.ByteString.Char8 as B
-import qualified Data.Map as Map
+import Data.Lens.Template
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time.Clock.POSIX
-import Data.Typeable
-import Control.Applicative
-import Control.Concurrent
-import Control.Exception (SomeException)
-import Control.Monad
-import Control.Monad.CatchIO
-import Control.Monad.Trans
-import Control.Monad.Reader
import Foreign.C.Types
import Prelude hiding (catch)
import Snap.Http.Server
import Snap.StaticPages
-import Snap.Types
+import Snap.Core
+import Snap.Snaplet
+import Snap.Snaplet.Heist
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
-import Text.XmlHtml hiding (Node)
-
-
-
-------------------------------------------------------------------------------
--- snapframework.com site state
-------------------------------------------------------------------------------
-data SiteState = SiteState {
- _origTs :: TemplateState Snap
- , _currentTs :: MVar (TemplateState Snap)
- , _staticTagCache :: StaticTagState
- , _blogState :: MVar StaticPagesState
-}
+data App = App
+ { _heist :: Snaplet (Heist App)
+ , _blog :: Snaplet StaticPages
+ }
-type Site a = ReaderT SiteState Snap a
+makeLenses [''App]
+instance HasHeist App where heistLens = subSnaplet heist
epochTime :: IO CTime
epochTime = do
t <- getPOSIXTime
return $ fromInteger $ truncate t
-initSiteState :: IO SiteState
-initSiteState = do
- setLocaleToUTF8
+description :: Text
+description = "The snapframework.com website"
- (origTs,staticState) <- bindStaticTag .
- bindSplice "snap-version" serverVersion .
- bindString "feed-autodiscovery-link" "" $
- emptyTemplateState "templates"
+appInit :: SnapletInit App App
+appInit = makeSnaplet "snap-website" description Nothing $ do
+ liftIO setLocaleToUTF8
+ hs <- nestSnaplet "" heist $ heistInit "templates"
+ bs <- nestSnaplet "blog" blog $ staticPagesInit "blogdata"
+ addSplices [ ("snap-version", serverVersion)
+ , ("feed-autodiscovery-link", liftHeist $ textSplice "")
+ ]
+ wrapHandlers (\h -> catch500 $ withCompression $
+ h <|> setCache (serveDirectory "static"))
+ return $ App hs bs
- ets <- loadTemplates "templates" origTs
- let ts = either error id ets
- either (\s -> putStrLn (loadError s) >> exitFailure) (const $ return ()) ets
- tsMVar <- newMVar $ ts
- bs <- loadStaticPages' ts "blogdata"
-
- return $ SiteState origTs tsMVar staticState bs
-
-
-data ReloadException = ReloadException String
- deriving (Show, Typeable)
-
-instance Exception ReloadException
-
-
-reloadSiteState :: SiteState -> IO ()
-reloadSiteState ss = do
- clearStaticTagCache $ _staticTagCache ss
- ts <- loadTemplates "templates" $ _origTs ss
- tt <- either (\msg -> throw $ ReloadException $ loadError msg)
- (\t -> do
- modifyMVar_ (_currentTs ss) (const $ return t)
- return t)
- ts
- reloadStaticPages' tt $ _blogState ss
-
-
-------------------------------------------------------------------------------
--- 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 (writeBuilder . fst) =<< renderTemplate ts n
-
-
-templateServe :: MVar (TemplateState Snap)
- -> Snap ()
-templateServe tsMVar = do
- p
- modifyResponse $ setContentType "text/html"
-
- where
- p = ifTop (renderTmpl tsMVar "index") <|>
- (renderTmpl tsMVar . B.pack =<< getSafePath)
+setCache :: MonadSnap m => m a -> m ()
+setCache act = do
+ pinfo <- liftM rqPathInfo getRequest
+ act
+ when ("media" `B.isPrefixOf` pinfo) $ do
+ expTime <- liftM (+604800) $ liftIO epochTime
+ s <- liftIO $ formatHttpTime expTime
+ modifyResponse $
+ setHeader "Cache-Control" "public, max-age=604800" .
+ setHeader "Expires" s
-loadError :: String -> String
-loadError str = "Error loading templates\n"++str
-
-
-
-------------------------------------------------------------------------------
--- handlers
-------------------------------------------------------------------------------
-site :: SiteState -> Snap ()
-site ss =
- catch500 $ withCompression $
- route [ ("docs/api", runReaderT apidoc ss)
- , ("admin/reload", runReaderT reload ss)
- , ("blog/", serveStaticPages (_blogState ss)) ] <|>
- templateServe (_currentTs ss) <|>
- (setCache $ serveDirectory "static")
-
- where
- setCache act = do
- pinfo <- liftM rqPathInfo getRequest
- act
- when ("media" `B.isPrefixOf` pinfo) $ do
- expTime <- liftM (+604800) $ liftIO epochTime
- s <- liftIO $ formatHttpTime expTime
- modifyResponse $
- setHeader "Cache-Control" "public, max-age=604800" .
- setHeader "Expires" s
-
-catch500 :: Snap a -> Snap ()
+catch500 :: MonadSnap m => m a -> m ()
catch500 m = (m >> return ()) `catch` \(e::SomeException) -> do
let t = T.pack $ show e
putResponse r
@@ -163,57 +89,6 @@ catch500 m = (m >> return ()) `catch` \(e::SomeException) -> do
r = setContentType "text/html" $
setResponseStatus 500 "Internal Server Error" emptyResponse
-reload :: Site ()
-reload = do
- e <- try (ask >>= liftIO . reloadSiteState)
- lift $ do
- either bad good e
- modifyResponse $ setContentType "text/plain; charset=utf-8"
-
- where
- bad :: SomeException -> Snap ()
- bad msg = writeBS $ B.pack $ loadError (show msg) ++ "Keeping old templates."
- good _ = writeBS "Templates loaded successfully"
-
-
-apidoc :: Site ()
-apidoc = do
- ss <- ask
-
- lift $ do
- ts <- liftIO $ readMVar $ _currentTs ss
- -- remainder of pathInfo is the doc to lookup
- whichDoc <- liftM (T.decodeUtf8 . rqPathInfo) getRequest
-
- title <- maybe pass return $ Map.lookup whichDoc titles
- let href = T.concat ["/docs/latest/", whichDoc, "/index.html"]
-
- let ts' = bindSplice "docframe" (docframe href) $
- bindSplice "subtitle" (return [TextNode title]) ts
-
- modifyResponse $ setContentType "text/html"
- maybe pass (writeBuilder . fst) =<< renderTemplate ts' "docs/api"
-
- where
- titles = Map.fromList [ ("snap-core", ": snap-core APIs")
- , ("snap-server", ": snap-server APIs")
- , ("heist", ": heist APIs") ]
-
- docframe :: Text -> Splice Snap
- docframe src = return [ Element "frame" [ ("id" , "docframe")
- , ("src", src ) ] [] ]
-
-
-
-
-
-------------------------------------------------------------------------------
--- MISC UTILITIES
-------------------------------------------------------------------------------
-serverVersion :: Splice Snap
-serverVersion = return [TextNode (T.decodeUtf8 snapServerVersion)]
-
-
setLocaleToUTF8 :: IO ()
setLocaleToUTF8 = do
mapM_ (\k -> setEnv k "en_US.UTF-8" True)
@@ -233,14 +108,9 @@ setLocaleToUTF8 = do
, "LC_ALL" ]
-------------------------------------------------------------------------------
--- main
-------------------------------------------------------------------------------
-main :: IO ()
-main = do
- ss <- initSiteState
+serverVersion :: SnapletSplice b v
+serverVersion = liftHeist $ textSplice $ T.decodeUtf8 snapServerVersion
- quickHttpServe (site ss)
+main :: IO ()
+main = serveSnaplet defaultConfig appInit
- putStrLn "exiting"
- return ()
@@ -2,7 +2,7 @@
<static>
<apply template="page">
<div class="singlecolumn">
- <markdown file="docs/quickstart.md"/>
+ <markdown file="quickstart.md"/>
</div>
</apply>
</static>
@@ -2,7 +2,7 @@
<static>
<apply template="page">
<div class="singlecolumn">
- <markdown file="docs/tutorials/heist.md"/>
+ <markdown file="heist.md"/>
</div>
</apply>
</static>
@@ -2,7 +2,7 @@
<static>
<apply template="page">
<div class="singlecolumn">
- <markdown file="docs/tutorials/snap-api-0.4.md"/>
+ <markdown file="snap-api-0.4.md"/>
</div>
</apply>
</static>
Oops, something went wrong.

0 comments on commit 2c9aacc

Please sign in to comment.