diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,32 @@ +web-page license +Copyright (c) 2014, Ertugrul Soeylemez + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + + * Neither the name of the author nor the names of any contributors + may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,7 @@ +Web-page +======== + +This package combines blaze-html, clay, jmacro and web-routes into a +framework-agnostic library to generate web pages dynamically from +individual components. It is inspired by Yesod's widgets, but is more +general, more powerful and can be used with other web frameworks. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,12 @@ +web-page setup script +Copyright (C) 2014, Ertugrul Soeylemez + +Please see the LICENSE file for terms and conditions of use, +modification and distribution of this package, including this file. + +> module Main where +> +> import Distribution.Simple +> +> main :: IO () +> main = defaultMain diff --git a/Web/Page.hs b/Web/Page.hs new file mode 100644 --- /dev/null +++ b/Web/Page.hs @@ -0,0 +1,19 @@ +-- | +-- Module: Web.Page +-- Copyright: (c) 2014 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez + +module Web.Page + ( -- * Reexports + module Web.Page.Render, + module Web.Page.Widget, + + -- * External + module Control.Monad.Writer.Strict + ) + where + +import Control.Monad.Writer.Strict +import Web.Page.Render +import Web.Page.Widget diff --git a/Web/Page/Render.hs b/Web/Page/Render.hs new file mode 100644 --- /dev/null +++ b/Web/Page/Render.hs @@ -0,0 +1,140 @@ +-- | +-- Module: Web.Page.Render +-- Copyright: (c) 2014 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- This module provides the functionality to render web pages. This is +-- the process to construct and then render a web page: +-- +-- 1. Use a writer monad to construct a 'Widget', which represents a +-- web page component and is usually constructed from multiple +-- smaller components, +-- +-- 2. use one of the rendering functions to render a widget to a +-- 'Page', which represents a rendered web page, but still abstracts +-- over the exact set of documents (everything inline or a set of +-- separate documents for markup, script and style), +-- +-- 3. turn the page into a set of documents that you can deliver to the +-- client, for example by using 'inlinePage'. +-- +-- The motivation for rendering to separate documents is that most web +-- pages consist of dynamic markup, but the stylesheet and script is +-- mostly static. The way 'Page' works you can have widgets with +-- batteries included and still render to separate documents to utilise +-- the client's cache better. +-- +-- Helper functions for doing that are defined in this module, but +-- framework-specific support is necessary to make this work. + +module Web.Page.Render + ( -- * Rendering pages + Page(..), + renderWidget, + + -- * Single document + inlinePage + ) + where + +import qualified Clay +import qualified Data.ByteString.Lazy as Bl +import qualified Data.Map.Strict as M +import qualified Data.Text.Lazy as Tl +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A +import qualified Text.PrettyPrint.Leijen.Text as Pp +import Data.Foldable (foldMap) +import Data.Monoid +import Data.Text (Text) +import Language.Javascript.JMacro (renderJs) +import Text.Blaze.Html +import Text.Blaze.Html.Renderer.Utf8 +import Web.Page.Widget + + +-- | Rendered pages. This type supports rendering to multiple documents +-- like an HTML document, as explained above. +-- +-- If you're running a low-traffic site and don't want to afford the +-- complexity, then you can just include the stylesheets and scripts +-- inline by using the 'inlinePage' function. Except for external +-- script and style URLs this will give you a self-contained document +-- that you can deliver to the client. +-- +-- The 'pageHtml' field is the function that takes the markup for the +-- script and the style respectively and returns a lazy bytestring that +-- you can send as @text/html@ to the client. The other two fields are +-- the rendered script and stylesheet. The markup is UTF-8-encoded, +-- which you should indicate in the @content-type@ header, if you +-- deliver via HTTP. + +data Page = + Page { + pageHtml :: Html -> Html -> Bl.ByteString, -- ^ Markup document. + pageScript :: Tl.Text, -- ^ Page script. + pageStyle :: Tl.Text -- ^ Page stylesheet. + } + + +-- | Render the given page to a single self-contained document, +-- including the script and stylesheet inline. + +inlinePage :: Page -> Bl.ByteString +inlinePage p = pageHtml p scInc stInc + where + Page { pageScript = sc, + pageStyle = st + } = p + + scInc | Tl.null sc = mempty + | otherwise = H.script (toHtml sc) + + stInc | Tl.null st = mempty + | otherwise = H.style (toHtml st) + + +-- | This is the most general rendering function for widgets. + +renderWidget :: + (Ord k) + => [k] -- ^ Sections to render. + -> ([Text] -> Text) -- ^ Title renderer. + -> Widget k Text -- ^ Widget to render. + -> Page +renderWidget ss renderTitle w = + Page { pageHtml = \scInc stInc -> renderHtml (html scInc stInc), + pageScript = Pp.displayT . Pp.renderOneLine . renderJs . _wScript $ w, + pageStyle = Clay.renderWith Clay.compact [] . _wStyle $ w } + + where + html :: Html -> Html -> Html + html scInc stInc = + H.docType <> + H.html (H.head headH <> + H.body bodyH) + + where + bodyH = + foldMap section ss <> + foldMap scLink (_wScriptLinks w) <> + scInc + + headH = + H.title (toHtml title) <> + _wHead w <> + foldMap stLink (_wStyleLinks w) <> + stInc + + section = + maybe mempty id . + (`M.lookup` _wSections w) + + scLink url = H.script mempty ! A.src (toValue url) + + stLink url = + H.link ! A.rel "stylesheet" + ! A.href (toValue url) + + title = renderTitle . maybe [] id . getLast . _wTitle $ w diff --git a/Web/Page/Widget.hs b/Web/Page/Widget.hs new file mode 100644 --- /dev/null +++ b/Web/Page/Widget.hs @@ -0,0 +1,219 @@ +-- | +-- Module: Web.Page.Widget +-- Copyright: (c) 2014 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- A widget is a self-contained web page component represented by the +-- 'Widget' type. This type is a family of monoids, so you can use it +-- together with a writer monad. + +module Web.Page.Widget + ( -- * Page widgets + Widget(..), + + -- * Widget actions + MonadWidget, + WidgetWriter, + + -- * Constructing widgets + addBody, + addHead, + addScript, + addScriptLink, + addSection, + addStyle, + addStyleLink, + setTitle, + withTitle, + + -- * Widget lenses + wHead, + wScript, + wScriptLinks, + wSections, + wStyle, + wStyleLinks, + wTitle + ) + where + +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import Clay (Css) +import Control.Applicative +import Control.Lens +import Control.Monad.Writer.Class +import Data.Foldable (Foldable) +import Data.Map (Map) +import Data.Monoid +import Data.Set (Set) +import Data.Text (Text) +import Data.Typeable +import Language.Javascript.JMacro (JStat) +import Text.Blaze.Html + + +-- | Convenient constraint alias for widget actions. + +type MonadWidget k url = MonadWriter (Widget k url) + + +-- | A widget is a self-contained fragment of a web page together with +-- its scripts and styles. This type is inspired by Yesod's widgets, +-- but is supposed to be constructed by using a writer monad and may not +-- denote effects of its own. +-- +-- To construct widgets through a writer monad, use lens combinators +-- like 'scribe' and 'censoring'. Alternatively you can use the @add*@ +-- functions like 'addSection' or 'addStyle'. The title is constructed +-- by using 'withTitle' and 'setTitle'. This allows you to have a +-- hierarchy of titles with a site title, a page title and even a +-- component title. +-- +-- The first type argument is the key type for the individual body +-- sections of the resulting document. You can use it for example to +-- divide your document into a header, a menu, a content area and a +-- footer and each widget can add to them individually. +-- +-- The second type argument is the type of URLs. You may use it for +-- type-safe routing. + +data Widget k url = + Widget { + _wHead :: Html, -- ^ Head content. + _wScript :: JStat, -- ^ Inline scripts. + _wScriptLinks :: Set url, -- ^ External scripts. + _wSections :: Map k Html, -- ^ Contents of body sections. + _wStyle :: Css, -- ^ Stylesheet. + _wStyleLinks :: Set url, -- ^ External stylesheets. + _wTitle :: Last [Text] -- ^ Page title chunks (outermost first). + } + deriving (Foldable, Typeable) + +instance (Ord k, Ord url) => Monoid (Widget k url) where + mempty = + Widget { _wHead = mempty, + _wScript = mempty, + _wScriptLinks = mempty, + _wSections = M.empty, + _wStyle = return (), + _wStyleLinks = mempty, + _wTitle = mempty } + + mappend w1 w2 = + Widget { _wHead = _wHead w1 <> _wHead w2, + _wScript = _wScript w1 <> _wScript w2, + _wScriptLinks = _wScriptLinks w1 <> _wScriptLinks w2, + _wSections = M.unionWith (<>) (_wSections w1) (_wSections w2), + _wStyle = _wStyle w1 >> _wStyle w2, + _wStyleLinks = _wStyleLinks w1 <> _wStyleLinks w2, + _wTitle = _wTitle w1 <> _wTitle w2 } + + +-- | Convenient type alias for polymorphic widget actions. + +type WidgetWriter k url a = forall m. (MonadWidget k url m) => m a + + +-- | Construct a widget with the given body. Use this combinator if you +-- don't need sections. + +addBody :: (MonadWriter (Widget () url) m) => Html -> m () +addBody = addSection () + + +-- | Construct a widget with the given head markup. + +addHead :: (MonadWriter (Widget k url) m) => Html -> m () +addHead = scribe wHead + + +-- | Construct a widget with the given script. + +addScript :: (MonadWriter (Widget k url) m) => JStat -> m () +addScript = scribe wScript + + +-- | Construct a widget with the given script link. + +addScriptLink :: (MonadWriter (Widget k url) m) => url -> m () +addScriptLink url = scribe wScriptLinks (S.singleton url) + + +-- | Construct a widget with the given body section. + +addSection :: (MonadWriter (Widget k url) m) => k -> Html -> m () +addSection k = scribe wSections . M.singleton k + + +-- | Construct a widget with the given stylesheet. + +addStyle :: (MonadWriter (Widget k url) m) => Css -> m () +addStyle = scribe wStyle + + +-- | Construct a widget with the given style link. + +addStyleLink :: (MonadWriter (Widget k url) m) => url -> m () +addStyleLink url = scribe wStyleLinks (S.singleton url) + + +-- | Scribe the title of the widget. Use this function to construct the +-- lowest level title. For higher level titles use 'withTitle'. + +setTitle :: (MonadWriter (Widget k url) m) => Text -> m () +setTitle x = scribe wTitle (Last (Just [x])) + + +-- | Lens into a widget's head. + +wHead :: Lens' (Widget k url) Html +wHead l w = (\x -> w { _wHead = x }) <$> l (_wHead w) + + +-- | Prepend the given title chunk to the given widget action. +-- Conceptually this wraps the given widget in a higher level title. +-- Use 'setTitle' for the lowest level title. + +withTitle :: (MonadWriter (Widget k url) m) => Text -> m a -> m a +withTitle x = censoring wTitle f + where + f (Last Nothing) = Last Nothing + f (Last (Just xs)) = Last (Just (x:xs)) + + +-- | Lens into a widget's inline script. + +wScript :: Lens' (Widget k url) JStat +wScript l w = (\x -> w { _wScript = x }) <$> l (_wScript w) + + +-- | Lens into a widget's external scripts. + +wScriptLinks :: Lens' (Widget k url) (Set url) +wScriptLinks l w = (\x -> w { _wScriptLinks = x }) <$> l (_wScriptLinks w) + + +-- | Lens into a widget's body sections. + +wSections :: Lens' (Widget k url) (Map k Html) +wSections l w = (\x -> w { _wSections = x }) <$> l (_wSections w) + + +-- | Lens into a widget's inline style. + +wStyle :: Lens' (Widget k url) Css +wStyle l w = (\x -> w { _wStyle = x }) <$> l (_wStyle w) + + +-- | Lens into a widget's external styles. + +wStyleLinks :: Lens' (Widget k url) (Set url) +wStyleLinks l w = (\x -> w { _wStyleLinks = x }) <$> l (_wStyleLinks w) + + +-- | Lens into a widget's title. + +wTitle :: Lens' (Widget k url) (Last [Text]) +wTitle l w = (\x -> w { _wTitle = x }) <$> l (_wTitle w) diff --git a/default.nix b/default.nix new file mode 100644 --- /dev/null +++ b/default.nix @@ -0,0 +1,29 @@ +# -*-conf-*- + +{ pkgs ? import { }, devel ? false }: + +let hs = pkgs.haskellPackages; + inherit (hs) cabal; + + develDepends = with hs; [ + ]; +in + +cabal.mkDerivation (self : rec { + pname = "web-page"; + version = "0.1.0"; + isExecutable = false; + isLibrary = true; + preConfigure = ''rm -rf dist''; + src = if devel then ./. else pkgs.fetchdarcs { url = ./.; }; + + buildDepends = with hs; [ + blazeHtml + clay + jmacro + lens + mtl + webRoutes + wlPprintText + ] ++ (if devel then develDepends else []); +}) diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,43 @@ +-- | +-- Module: Main +-- Copyright: (c) 2014 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez + +module Main where + +import qualified Data.ByteString.Lazy.Char8 as Blc +import qualified Data.Text as T +import qualified Text.Blaze.Html5 as H +import Clay +import Data.Text (Text) +import Language.Javascript.JMacro +import Web.Page + + +data Section = Header | Content | Footer + deriving (Eq, Ord, Show) + + +myWidget :: WidgetWriter Section Text () +myWidget = + withTitle "Test site" $ do + setTitle "Test page" + addSection Footer (H.p "copyright crap") + addScript [jmacro| alert("haha") |] + addSection Header (H.h1 "blah") + addStyle $ "html" ? do + background white + color black + + addScriptLink "/js/blah.js" + addStyleLink "/style/screen.css" + + +main :: IO () +main = do + let w = execWriter myWidget + p = renderWidget [Header, Content, Footer] (T.intercalate " - ") w + d = inlinePage p + + Blc.putStrLn d diff --git a/web-page.cabal b/web-page.cabal new file mode 100644 --- /dev/null +++ b/web-page.cabal @@ -0,0 +1,74 @@ +name: web-page +version: 0.1.0 +category: Web +synopsis: Monoidally construct web pages +maintainer: Ertugrul Söylemez +author: Ertugrul Söylemez +copyright: (c) 2014 Ertugrul Söylemez +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: README.md default.nix +description: + This package combines blaze-html, clay, jmacro and web-routes into a + framework-agnostic library to generate web pages dynamically from + individual components. It is inspired by Yesod's widgets, but is + more general, more powerful and can be used with other web + frameworks. + +flag TestProgram + default: False + description: Build the test program + manual: True + +source-repository head + type: darcs + location: http://hub.darcs.net/ertes/web-page + +library + build-depends: + base >= 4.5 && < 5, + blaze-html >= 0.7 && < 1, + bytestring >= 0.10 && < 1, + clay >= 0.9 && < 1, + containers >= 0.5 && < 1, + jmacro >= 0.6 && < 1, + lens >= 4.4 && < 5, + mtl >= 2.1 && < 3, + text >= 1.0 && < 2, + wl-pprint-text >= 1.1 && < 2 + default-language: Haskell2010 + default-extensions: + ConstraintKinds + DeriveDataTypeable + DeriveFoldable + FlexibleContexts + OverloadedStrings + RankNTypes + ghc-options: -W + exposed-modules: + Web.Page + Web.Page.Render + Web.Page.Widget + +executable web-page-test + if flag(testprogram) + build-depends: + base >= 4.5 && < 5, + blaze-html, + bytestring, + clay, + jmacro, + text, + web-page + else + buildable: False + default-language: Haskell2010 + default-extensions: + FlexibleContexts + OverloadedStrings + QuasiQuotes + ghc-options: -threaded -rtsopts + hs-source-dirs: test + main-is: Test.hs