Allow attributes on <script> and <link> tags

Yesod/Core.hs

@@ -45,7 +45,9 @@ import Control.Monad.Trans.RWS
 import Text.Hamlet
 import Text.Cassius
 import Text.Julius
-import Text.Blaze (preEscapedLazyText)
+import Text.Blaze (preEscapedLazyText, (!), customAttribute, textTag, toValue)
+import qualified Data.Text as T
+import qualified Text.Blaze.Html5 as TBH
 import Data.Text.Lazy.Builder (toLazyText)
 import Data.Text.Lazy.Encoding (encodeUtf8)
 import Data.Maybe (fromMaybe)
@@ -59,6 +61,7 @@ import qualified Data.Text as TS
 import Data.Text (Text)
 import qualified Data.Text.Encoding as TE
 import Blaze.ByteString.Builder (Builder, fromByteString, toByteString)
+import Data.List (foldl')
 
 #if GHC7
 #define HAMLET hamlet
@@ -232,16 +235,15 @@ defaultYesodRunner :: Yesod master
                    -> GHandler a master ChooseRep
                    -> W.Application
 defaultYesodRunner s master toMasterRoute mkey murl handler req = do
+    now <- liftIO getCurrentTime
     let getExpires m = fromIntegral (m * 60) `addUTCTime` now
     let exp' = getExpires $ clientSessionDuration master
     let rh = takeWhile (/= ':') $ show $ W.remoteHost req
     let host = if sessionIpAddress master then S8.pack rh else ""
-    session' <-
-        case mkey of
-            Nothing -> return []
-            Just key -> do
-                now <- liftIO getCurrentTime
-                return $ fromMaybe [] $ do
+    let session' =
+            case mkey of
+                Nothing -> []
+                Just key -> fromMaybe [] $ do
                     raw <- lookup "Cookie" $ W.requestHeaders req
                     val <- lookup sessionName $ parseCookies raw
                     decodeSession key now host val
@@ -404,9 +406,8 @@ widgetToPageContent :: (Eq (Route master), Yesod master)
 widgetToPageContent (GWidget w) = do
     ((), _, GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- runRWST w () 0
     let title = maybe mempty unTitle mTitle
-    let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts'
-    let stylesheets = map (locationToHamlet . unStylesheet)
-                    $ runUniqueList stylesheets'
+    let scripts = runUniqueList scripts'
+    let stylesheets = runUniqueList stylesheets'
     let cssToHtml = preEscapedLazyText . renderCss
         celper :: Cassius url -> Hamlet url
         celper = fmap cssToHtml
@@ -436,6 +437,13 @@ widgetToPageContent (GWidget w) = do
                    $ encodeUtf8 $ renderJulius render s
                 return $ renderLoc x
 
+    let addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z)
+    let renderLoc' render' (Local url) = render' url []
+        renderLoc' _ (Remote s) = s
+    let mkScriptTag (Script loc attrs) render' =
+            foldl' addAttr TBH.script (("src", T.pack $ renderLoc' render' loc) : attrs) $ return ()
+    let mkLinkTag (Stylesheet loc attrs) render' =
+            foldl' addAttr TBH.link (("rel", "stylesheet") : ("href", T.pack $ renderLoc' render' loc) : attrs)
     let head'' =
 #if GHC7
             [hamlet|
@@ -443,12 +451,12 @@ widgetToPageContent (GWidget w) = do
             [$hamlet|
 #endif
 $forall s <- scripts
-    <script src="^{s}">
+    ^{mkScriptTag s}
 $forall s <- stylesheets
-    <link rel="stylesheet" href="^{s}">
+    ^{mkLinkTag s}
 $maybe s <- style
     $maybe s <- cssLoc
-        <link rel="stylesheet" href="#{s}">
+        <link rel=stylesheet href=#{s}
     $nothing
         <style>^{celper s}
 $maybe j <- jscript

Yesod/Internal.hs

@@ -83,7 +83,7 @@ data Header =
 langKey :: A.Ascii
 langKey = "_LANG"
 
-data Location url = Local url | Remote String
+data Location url = Local url | Remote String -- FIXME Text
     deriving (Show, Eq)
 locationToHamlet :: Location url -> Hamlet url
 locationToHamlet (Local url) = [HAMLET|\@{url}
@@ -100,9 +100,9 @@ runUniqueList (UniqueList x) = nub $ x []
 toUnique :: x -> UniqueList x
 toUnique = UniqueList . (:)
 
-newtype Script url = Script { unScript :: Location url }
+data Script url = Script { scriptLocation :: Location url, scriptAttributes :: [(T.Text, T.Text)] }
     deriving (Show, Eq)
-newtype Stylesheet url = Stylesheet { unStylesheet :: Location url }
+data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttributes :: [(T.Text, T.Text)] }
     deriving (Show, Eq)
 newtype Title = Title { unTitle :: Html }
 

Yesod/Widget.hs

@@ -21,12 +21,16 @@ module Yesod.Widget
       -- ** CSS
     , addCassius
     , addStylesheet
+    , addStylesheetAttrs
     , addStylesheetRemote
+    , addStylesheetRemoteAttrs
     , addStylesheetEither
       -- ** Javascript
     , addJulius
     , addScript
+    , addScriptAttrs
     , addScriptRemote
+    , addScriptRemoteAttrs
     , addScriptEither
       -- * Utilities
     , extractBody
@@ -44,6 +48,7 @@ import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.Trans.Class (MonadTrans (lift))
 import Yesod.Internal
 import Control.Monad (liftM)
+import Data.Text (Text)
 
 import Control.Monad.IO.Peel (MonadPeelIO)
 
@@ -118,11 +123,19 @@ addCassius x = GWidget $ tell $ GWData mempty mempty mempty mempty (Just x) memp
 
 -- | Link to the specified local stylesheet.
 addStylesheet :: Monad m => Route master -> GGWidget sub master m ()
-addStylesheet x = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet $ Local x) mempty mempty mempty
+addStylesheet = flip addStylesheetAttrs []
+
+-- | Link to the specified local stylesheet.
+addStylesheetAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget sub master m ()
+addStylesheetAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
 
 -- | Link to the specified remote stylesheet.
 addStylesheetRemote :: Monad m => String -> GGWidget sub master m ()
-addStylesheetRemote x = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet $ Remote x) mempty mempty mempty
+addStylesheetRemote = flip addStylesheetRemoteAttrs []
+
+-- | Link to the specified remote stylesheet.
+addStylesheetRemoteAttrs :: Monad m => String -> [(Text, Text)] -> GGWidget sub master m ()
+addStylesheetRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
 
 addStylesheetEither :: Monad m => Either (Route master) String -> GGWidget sub master m ()
 addStylesheetEither = either addStylesheet addStylesheetRemote
@@ -132,11 +145,19 @@ addScriptEither = either addScript addScriptRemote
 
 -- | Link to the specified local script.
 addScript :: Monad m => Route master -> GGWidget sub master m ()
-addScript x = GWidget $ tell $ GWData mempty mempty (toUnique $ Script $ Local x) mempty mempty mempty mempty
+addScript = flip addScriptAttrs []
+
+-- | Link to the specified local script.
+addScriptAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget sub master m ()
+addScriptAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
 
 -- | Link to the specified remote script.
 addScriptRemote :: Monad m => String -> GGWidget sub master m ()
-addScriptRemote x = GWidget $ tell $ GWData mempty mempty (toUnique $ Script $ Remote x) mempty mempty mempty mempty
+addScriptRemote = flip addScriptRemoteAttrs []
+
+-- | Link to the specified remote script.
+addScriptRemoteAttrs :: Monad m => String -> [(Text, Text)] -> GGWidget sub master m ()
+addScriptRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
 
 -- | Include raw Javascript in the page's script tag.
 addJulius :: Monad m => Julius (Route master) -> GGWidget sub master m ()