From 5190a5eabb1b4188d8c6fbc1d074d369d46d09f4 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Sun, 8 Aug 2010 12:48:08 +0300
Subject: [PATCH] addStaticContent

---
 Yesod/Widget.hs | 37 ++++++++++++++++++++++++++++++++-----
 Yesod/Yesod.hs  | 17 +++++++++++++++++
 hellowidget.hs  | 12 +++++++++++-
 3 files changed, 60 insertions(+), 6 deletions(-)

diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs
index fc3e26c5..cc908b20 100644
--- a/Yesod/Widget.hs
+++ b/Yesod/Widget.hs
@@ -38,8 +38,8 @@ import Control.Monad.Trans.State
 import Yesod.Hamlet (Hamlet, hamlet, PageContent (..), Html)
 import Text.Camlet
 import Text.Jamlet
-import Yesod.Handler (Route, GHandler)
-import Yesod.Yesod (Yesod, defaultLayout)
+import Yesod.Handler (Route, GHandler, getUrlRender)
+import Yesod.Yesod (Yesod, defaultLayout, addStaticContent)
 import Yesod.Content (RepHtml (..))
 import Control.Applicative (Applicative)
 import Control.Monad.IO.Class (MonadIO)
@@ -159,7 +159,7 @@ applyLayoutW :: (Eq (Route m), Yesod m)
 applyLayoutW w = widgetToPageContent w >>= fmap RepHtml . defaultLayout
 
 -- | Convert a widget to a 'PageContent'.
-widgetToPageContent :: Eq (Route master)
+widgetToPageContent :: (Eq (Route master), Yesod master)
                     => GWidget sub master ()
                     -> GHandler sub master (PageContent (Route master))
 widgetToPageContent (GWidget w) = do
@@ -186,15 +186,42 @@ widgetToPageContent (GWidget w) = do
     let jelper :: Jamlet url -> Hamlet url
         jelper j render = lbsToHtml $ renderJamlet render j
 
+    render <- getUrlRender
+    let renderLoc x =
+            case x of
+                Nothing -> Nothing
+                Just (Left s) -> Just s
+                Just (Right u) -> Just $ render u
+    cssLoc <-
+        case style of
+            Nothing -> return Nothing
+            Just s -> do
+                x <- addStaticContent "css" "text/css; charset=utf-8"
+                   $ renderCamlet render s
+                return $ renderLoc x
+    jsLoc <-
+        case jscript of
+            Nothing -> return Nothing
+            Just s -> do
+                x <- addStaticContent "js" "text/javascript; charset=utf-8"
+                   $ renderJamlet render s
+                return $ renderLoc x
+
     let head'' = [$hamlet|
 $forall scripts s
     %script!src=^s^
 $forall stylesheets s
     %link!rel=stylesheet!href=^s^
 $maybe style s
-    %style ^celper.s^
+    $maybe cssLoc s
+        %link!rel=stylesheet!href=$s$
+    $nothing
+        %style ^celper.s^
 $maybe jscript j
-    %script ^jelper.j^
+    $maybe jsLoc s
+        %script!src=$s$
+    $nothing
+        %script ^jelper.j^
 ^head'^
 |]
     return $ PageContent title head'' body
diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs
index a792c321..2830d6ee 100644
--- a/Yesod/Yesod.hs
+++ b/Yesod/Yesod.hs
@@ -45,6 +45,7 @@ import Control.Monad.Attempt (Failure)
 import qualified Data.ByteString as S
 import qualified Network.Wai.Middleware.CleanPath
 import Web.Routes (encodePathInfo)
+import qualified Data.ByteString.Lazy as L
 
 -- | This class is automatically instantiated when you use the template haskell
 -- mkYesod function. You should never need to deal with it directly.
@@ -163,6 +164,22 @@ class Eq (Route a) => Yesod a where
             | otherwise = [x, ""] -- append trailing slash
         fixSegs (x:xs) = x : fixSegs xs
 
+    -- | This function is used to store some static content to be served as an
+    -- external file. The most common case of this is stashing CSS and
+    -- JavaScript content in an external file; the "Yesod.Widget" module uses
+    -- this feature.
+    --
+    -- The return value is 'Nothing' if no storing was performed; this is the
+    -- default implementation. A 'Just' 'Left' gives the absolute URL of the
+    -- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is
+    -- necessary when you are serving the content outside the context of a
+    -- Yesod application, such as via memcached.
+    addStaticContent :: String -- ^ filename extension
+                     -> String -- ^ mime-type
+                     -> L.ByteString -- ^ content
+                     -> GHandler sub a (Maybe (Either String (Route a)))
+    addStaticContent _ _ _ = return Nothing
+
 data AuthResult = Authorized | AuthenticationRequired | Unauthorized String
     deriving (Eq, Show, Read)
 
diff --git a/hellowidget.hs b/hellowidget.hs
index 7f66626c..e6a4a30c 100644
--- a/hellowidget.hs
+++ b/hellowidget.hs
@@ -5,6 +5,9 @@ import Yesod.Helpers.Static
 import Yesod.Form.Jquery
 import Yesod.Form.Nic
 import Control.Applicative
+import qualified Data.ByteString.Lazy as L
+import System.Directory
+import Data.Digest.Pure.MD5
 
 data HW = HW { hwStatic :: Static }
 mkYesod "HW" [$parseRoutes|
@@ -13,7 +16,14 @@ mkYesod "HW" [$parseRoutes|
 /static StaticR Static hwStatic
 /autocomplete AutoCompleteR GET
 |]
-instance Yesod HW where approot _ = ""
+instance Yesod HW where
+    approot _ = ""
+    addStaticContent ext _ content = do
+        let fn = show (md5 content) ++ '.' : ext
+        liftIO $ createDirectoryIfMissing True "static/tmp"
+        liftIO $ L.writeFile ("static/tmp/" ++ fn) content
+        return $ Just $ Right $ StaticR $ StaticRoute ["tmp", fn]
+
 instance YesodNic HW
 instance YesodJquery HW
 wrapper h = [$hamlet|