webwire (empty) → 0.1.0
raw patch · 11 files changed
+1170/−0 lines, 11 filesdep +basedep +base64-bytestringdep +blaze-buildersetup-changed
Dependencies added: base, base64-bytestring, blaze-builder, blaze-html, bytestring, case-insensitive, containers, cookie, cprng-aes, hamlet, http-types, netwire, shakespeare-css, shakespeare-js, text, time, transformers, wai, wai-extra
Files
- LICENSE +32/−0
- Setup.hs +2/−0
- WebWire.hs +33/−0
- WebWire/Core.hs +126/−0
- WebWire/Render.hs +163/−0
- WebWire/Routing.hs +232/−0
- WebWire/Session.hs +115/−0
- WebWire/Tools.hs +111/−0
- WebWire/Types.hs +118/−0
- WebWire/Widget.hs +162/−0
- webwire.cabal +76/−0
+ LICENSE view
@@ -0,0 +1,32 @@+Webwire license+Copyright (c) 2011, 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ WebWire.hs view
@@ -0,0 +1,33 @@+-- |+-- Module: WebWire+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Convenience module.++module WebWire+ ( -- * Webwire reexports+ module WebWire.Core,+ module WebWire.Render,+ module WebWire.Routing,+ module WebWire.Session,+ module WebWire.Types,+ module WebWire.Tools,+ module WebWire.Widget,++ -- * External+ module FRP.NetWire,+ module Network.Wai+ )+ where++import FRP.NetWire+import Network.Wai+import WebWire.Core+import WebWire.Render+import WebWire.Routing+import WebWire.Session+import WebWire.Types+import WebWire.Tools+import WebWire.Widget
+ WebWire/Core.hs view
@@ -0,0 +1,126 @@+-- |+-- Module: WebWire.Core+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Core functionality.++module WebWire.Core+ ( -- * Running webwire applications+ webWire,++ -- * Simple webwires+ simpleWire,++ -- * Tools+ simpleError+ )+ where++import qualified Data.ByteString as B+import qualified Data.Map as M+import qualified Data.Text.Encoding as T+import Blaze.ByteString.Builder+import Blaze.ByteString.Builder.Char8+import Control.Arrow+import Control.Exception+import Control.Monad.Trans.State+import Data.ByteString (ByteString)+import Data.Map (Map)+import Data.Monoid+import FRP.NetWire+import Network.HTTP.Types+import Network.Wai+import Network.Wai.Parse+import Web.Cookie+import WebWire.Types+++-- | Present a very simple plaintext error page for the given status.++simpleError :: WebWire site Status Response+simpleError =+ proc status@(Status code msg) ->+ identity -<+ ResponseBuilder+ status+ [headerContentType "text/plain"]+ (mconcat [fromString (show code),+ fromByteString ": ",+ fromByteString msg])+++-- | Run a simple webwire. This wire type is for simple sites (usually+-- just test sites or temporary sites), which don't need a custom+-- 'WebSite' instance.++simpleWire :: (Application -> IO a) -> SimpleWire () Response -> IO a+simpleWire run = webWire run ()+++-- | Run a webwire application using the given WAI handler.++webWire ::+ forall a site.+ (Application -> IO a) -- ^ WAI handler to use.+ -> site -- ^ Site configuration.+ -> WebWire site () Response -- ^ Webwire application to run.+ -> IO a -- ^ Result of the WAI handler.+webWire run s appWire =+ withWire fullWire $ \sess -> do+ run $ \req -> do+ (postPars, postFiles) <- parseRequestBody tempFileSink req++ let qpars = M.fromList . map (second $ maybe B.empty id) . queryString $ req+ let cfg' = WebConfig { wcCookies = toCookies (requestHeaders req),+ wcCurrentPath = [],+ wcPostFiles = M.fromList postFiles,+ wcPostParams = M.fromList postPars,+ wcQueryParams = qpars,+ wcRequest = req,+ wcRequestPath = pathInfo req,+ wcRootPath = [],+ wcSetCookies = M.empty,+ wcSetHeaders = [],+ wcSite = s,+ wcWidget = mempty }++ (outp, cfg) <- liftIO (runStateT (stepWire () sess) cfg')++ let addh =+ wcSetHeaders cfg +++ (map ("Set-Cookie", ) . M.elems . wcSetCookies) cfg+ case outp of+ Right (ResponseFile s h fn fp) -> return (ResponseFile s (h ++ addh) fn fp)+ Right (ResponseBuilder s h ob) -> return (ResponseBuilder s (h ++ addh) ob)+ Right (ResponseEnumerator e) -> return (ResponseEnumerator $ \f -> e (\s h -> f s (h ++ addh)))+ Left ex ->+ return $ ResponseBuilder+ statusServerError+ ([headerContentType "text/plain"] ++ addh)+ (fromByteString "Internal server error: " `mappend` fromString (show ex))++ where+ fullWire :: WebWire site () Response+ fullWire =+ proc _ -> do+ mx <- exhibit appWire -< ()+ case mx of+ Right resp -> identity -< resp+ Left ex ->+ case fromException ex of+ Nothing -> inhibit -< ex+ Just (WebException status) -> simpleError -< status+ Just (WebRedirect status uri) -> do+ let headers = [("Location", T.encodeUtf8 uri),+ headerContentType "text/plain"]+ identity -< ResponseBuilder status headers mempty++ toCookies :: [Header] -> Map ByteString ByteString+ toCookies [] = M.empty+ toCookies ((name, value):hs)+ | name /= "Cookie" = toCookies hs+ | otherwise =+ let cookie = parseSetCookie value+ in M.insert (setCookieName cookie) (setCookieValue cookie) (toCookies hs)
+ WebWire/Render.hs view
@@ -0,0 +1,163 @@+-- |+-- Module: WebWire.Render+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Rendering module.++module WebWire.Render+ ( -- * Renderable types+ Renderable(..),+ render,+ respondOutput,++ -- * Default widget+ addWidget,+ renderDef+ )+ where++import qualified Data.ByteString.Char8 as BC+import Blaze.ByteString.Builder+import Blaze.ByteString.Builder.Char.Utf8+import Control.Arrow+import Control.Monad.Trans.State+import Data.ByteString (ByteString)+import Data.Monoid+import Data.Text (Text)+import FRP.NetWire+import Network.HTTP.Types+import Network.Wai+import Text.Blaze+import Text.Blaze.Renderer.Utf8+import Text.Cassius+import Text.Julius+import WebWire.Tools+import WebWire.Types+import WebWire.Widget+++-- | This class represents renderable types. Each renderable type can+-- support rendering to several target representations like HTML, JSON,+-- XML, etc.+--+-- For simple applications the predefined instances should suffice.++class Renderable src where+ -- | Render the input value as the most appropriate output type.+ toWebOutput :: WebWire site src WebOutput+ toWebOutput =+ toWebOutputHtml <+>+ toWebOutputPlain <+>+ toWebOutputGen++ -- | Render the input value as some appropriate output type.+ toWebOutputGen :: WebWire site src WebOutput+ toWebOutputGen = notFound++ -- | Render the input value as HTML.+ toWebOutputHtml :: WebWire site src WebOutput+ toWebOutputHtml = notFound++ -- | Render the input value as plain text.+ toWebOutputPlain :: WebWire site src WebOutput+ toWebOutputPlain = notFound+++-- | 'ByteString' strings render to fixed length plain text. Note that+-- UTF-8 encoding is assumed.++instance Renderable ByteString where+ toWebOutputPlain = arr (TextOutput True . fromByteString)+++-- | 'Css' values render to a CSS stylesheet.++instance Renderable Css where+ toWebOutputGen = arr (GenOutput False "text/css" . fromLazyText . renderCss)+++-- | HTML is rendered as text/html with an assumed character set of+-- UTF-8.++instance Renderable Html where+ toWebOutputHtml = arr (HtmlOutput False)+++-- | 'Javascript' values render to a JavaScript resource.++instance Renderable Javascript where+ toWebOutputGen = arr (GenOutput False "text/javascript" . fromLazyText . renderJavascript)+++-- | Strings render to variable length plain text.++instance Renderable String where+ toWebOutputPlain = arr (TextOutput False . fromString)+++-- | 'Text' strings render to fixed length plain text.++instance Renderable Text where+ toWebOutputPlain = arr (TextOutput True . fromText)+++-- | Widgets render to HTML in the way specified in "WebWire.Widget".++instance Renderable Widget where+ toWebOutputHtml = arr (HtmlOutput False . toHtml)+++-- | Add the input widget to the current default widget.++addWidget :: WebWire site Widget ()+addWidget =+ proc w ->+ execute -< modify $ \cfg ->+ let w' = wcWidget cfg+ in cfg { wcWidget = mappend w' w }+++-- | Render the given renderable value as a response to the user.++render :: Renderable src => WebWire site src Response+render = toWebOutput >>> respondOutput+++-- | Render the default widget.++renderDef :: WebWire site a Response+renderDef =+ proc _ -> do+ wg <- execute -< gets wcWidget+ render -< wg+++-- | Render the given output as a response to the user.++respondOutput :: WebWire site WebOutput Response+respondOutput =+ proc outp ->+ case outp of+ GenOutput withLen ctype ob ->+ identity -< builder withLen ctype ob+ HtmlOutput withLen html ->+ let ctype = "text/html; charset=UTF-8" in+ identity -< builder withLen ctype (renderHtmlBuilder html)+ TextOutput withLen ob ->+ let ctype = "text/plain; charset=UTF-8" in+ identity -< builder withLen ctype ob++ where+ builder :: Bool -> Ascii -> Builder -> Response+ builder False ctype ob =+ let hs = [headerContentType ctype] in+ ResponseBuilder statusOK hs ob+ builder True ctype ob =+ let ostr = toByteString ob+ olen = BC.length ostr+ hs =+ headerContentType ctype :+ headerContentLength (BC.pack (show olen)) : []+ in ResponseBuilder statusOK hs (fromByteString ostr)
+ WebWire/Routing.hs view
@@ -0,0 +1,232 @@+-- |+-- Module: WebWire.Routing+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Routing functionality.++module WebWire.Routing+ ( -- * Routing+ directory,+ file,+ rootDir,++ -- * Redirecting+ redirect,+ redirectRaw,+ seeOther,+ seeOtherRaw,++ -- * Paths+ cdIn,+ cdOut,+ currentDir,+ currentPath,+ pathAbs,+ pathRel,+ requestDir,+ requestPath,+ rootPath,+ setRoot+ )+ where++import qualified Data.Text as T+import Control.Monad.Trans.State+import Data.Text (Text)+import FRP.NetWire+import Network.HTTP.Types+import WebWire.Tools+import WebWire.Types+++-- | Remove the root request segment and add it to the current path.+-- Inhibits with a 404 error, if the request path is empty.++cdIn :: WebWire site a ()+cdIn =+ proc _ -> do+ reqPath <- requestPath -< ()+ case reqPath of+ [] -> notFound -< ()+ reqDir : restPath -> do+ execute -<+ modify $ \cfg ->+ let curPath = wcCurrentPath cfg+ in cfg { wcCurrentPath = reqDir : curPath,+ wcRequestPath = restPath }+++-- | Remove the current tail segment and add it to the request path.+-- Inhibits with a 404 error, if the current path is empty.++cdOut :: WebWire site a ()+cdOut =+ proc _ -> do+ curPath <- currentPath -< ()+ case curPath of+ [] -> notFound -< ()+ curDir : restPath -> do+ execute -<+ modify $ \cfg ->+ let reqPath = wcRequestPath cfg+ in cfg { wcCurrentPath = restPath,+ wcRequestPath = curDir : reqPath }+++-- | Output the current path segment, if there is one. Outputs+-- 'Nothing', if there are no further path segments. In particular, if+-- the root path is requested, this wire always returns 'Nothing'.++currentDir :: WebWire site a (Maybe Text)+currentDir =+ proc _ -> do+ curPath <- currentPath -< ()+ identity -<+ case curPath of+ [] -> Nothing+ (dir:_) -> Just dir+++-- | Output the current rest of the path segment.++currentPath :: WebWire site a [Text]+currentPath =+ proc _ -> execute -< gets wcCurrentPath+++-- | If the request root segment is the given directory, then removes+-- the root segment and adds it to the current path for the given wire.++directory :: Text -> WebWire site a b -> WebWire site a b+directory dir localWire =+ proc x' -> do+ mReqDir <- requestDir -< ()+ if maybe True (/= dir) mReqDir+ then notFound -< ()+ else do+ cdIn -< ()+ mx <- exhibit localWire -< x'+ cdOut -< ()+ inject -< mx+++-- | If the request root segment is the given file and there are no more+-- segments, then removes the last segment and adds it to the current+-- path for the given wire.++file :: Text -> WebWire site a b -> WebWire site a b+file fn localWire =+ proc x' -> do+ reqPath <- requestPath -< ()+ case reqPath of+ [seg] | seg == fn -> do+ cdIn -< ()+ mx <- exhibit localWire -< x'+ cdOut -< ()+ inject -< mx+ _ -> notFound -< ()+++-- | Construct the full URI to the given path from the root path.++pathAbs :: WebWire site [Text] Text+pathAbs =+ proc path -> do+ rp <- rootPath -< ()+ identity -< T.intercalate "/" . foldl (\es e -> e:es) path $ rp+++-- | Construct the full URI to the given path from the current path.++pathRel :: WebWire site [Text] Text+pathRel =+ proc path -> do+ curPath <- currentPath -< ()+ identity -< T.intercalate "/" . foldl (\es e -> e:es) path $ curPath+++-- | Redirect to the input URI. Inhibits with the appropriate+-- exception.++redirect :: RedirectType -> WebWire site Text b+redirect redirType =+ proc path ->+ redirectRaw redirType -< path+++-- | Redirect to the input URI. Inhibits with the appropriate+-- exception.++redirectRaw :: RedirectType -> WebWire site Text b+redirectRaw redirType =+ proc path -> do+ let status = case redirType of+ RedirectPermanent -> statusMovedPermanently+ RedirectSeeOther -> statusSeeOther+ RedirectTemporary -> Status 307 "Temporary redirect"+ inhibit -< WebRedirect status path+++-- | Output the root request path segment, if there is one. Outputs+-- 'Nothing', if there are no further path segments. In particular, if+-- the root path is requested, this wire always returns 'Nothing'.++requestDir :: WebWire site a (Maybe Text)+requestDir =+ proc _ -> do+ reqPath <- requestPath -< ()+ identity -<+ case reqPath of+ [] -> Nothing+ (dir:_) -> Just dir+++-- | Output the rest of the request path segment.++requestPath :: WebWire site a [Text]+requestPath =+ proc _ -> execute -< gets wcRequestPath+++-- | Run the given wire, if the current request path is empty.+-- Otherwise inhibit with 404.++rootDir :: WebWire site a b -> WebWire site a b+rootDir localWire =+ proc x' -> do+ reqPath <- requestPath -< ()+ if null reqPath+ then localWire -< x'+ else notFound -< ()+++-- | Output the current root path.++rootPath :: WebWire site a [Text]+rootPath =+ proc _ -> execute -< gets wcRootPath+++-- | Convenience interface to 'redirect' for the very common 303+-- redirection.++seeOther :: WebWire site Text b+seeOther = redirect RedirectSeeOther+++-- | Convenience interface to 'redirect' for the very common 303+-- redirection.++seeOtherRaw :: WebWire site Text b+seeOtherRaw = redirectRaw RedirectSeeOther+++-- | Set the current root path. This wire also resets the current path.++setRoot :: WebWire site [Text] ()+setRoot =+ proc path ->+ execute -< modify (\cfg -> cfg { wcCurrentPath = path,+ wcRootPath = path })
+ WebWire/Session.hs view
@@ -0,0 +1,115 @@+-- |+-- Module: WebWire.Session+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Reactive web session handling.++module WebWire.Session+ ( -- * Sessions+ SessionCfg(..),+ WebSession,+ defSessionCfg,+ session,++ -- * Session ids+ getSessId,+ setNewSessId+ )+ where++import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString as B+import Control.Arrow+import Crypto.Random.AESCtr+import Data.ByteString (ByteString)+import Data.Time.Clock+import FRP.NetWire+import FRP.NetWire.Wire (mkGen)+import WebWire.Tools+import WebWire.Types+++-- | Session configuration.++data SessionCfg =+ SessionCfg {+ -- | Validity duration of the session cookies.+ sessDuration :: Maybe NominalDiffTime,++ -- | Threshold of saved sessions, after which sessions can be+ -- deleted.+ sessThreshold :: Int,++ -- | Minimum validitity time. Younger sessions won't be killed on+ -- the server side.+ sessTimeLimit :: Time+ }+++-- | Session identifiers.++type WebSession = ByteString+++-- | Default session configuration.++defSessionCfg :: SessionCfg+defSessionCfg =+ SessionCfg { sessDuration = Nothing,+ sessThreshold = 1000,+ sessTimeLimit = 7200 }+++-- | Generate a new session id at every instant.++genSessId :: WebWire site a ByteString+genSessId =+ mkGen $ \_ _ -> do+ prng' <- liftIO makeSystem+ let (str, prng) = genRandomBytes prng' 32+ return (Right str, genSessId' prng)++ where+ genSessId' :: AESRNG -> WebWire site a ByteString+ genSessId' prng' =+ mkGen $ \_ _ ->+ let (str, prng) = genRandomBytes prng' 32 in+ return (Right str, genSessId' prng)+++-- | Get the current session id. Inhibits, if the client didn't have+-- one.++getSessId :: WebWire site (Maybe NominalDiffTime) WebSession+getSessId =+ proc validity -> do+ sessIdEncoded <- getCookie -< "SESSION"+ let sessIdStr = B64.decodeLenient (B.take 64 sessIdEncoded)+ require_ -< B.length sessIdStr == 32+ setCookieSimple -< ("SESSION", sessIdEncoded, validity)+ identity -< sessIdStr+++-- | Reactive session handling. The given wire is evolved for each user+-- session individually.++session :: SessionCfg -> WebWire site (WebSession, a) b -> WebWire site a b+session scfg userWire =+ proc x' -> do+ sessId <- getSessId <+> setNewSessId -< sessDuration scfg+ contextLimited userWire -<+ (sessThreshold scfg, sessTimeLimit scfg, sessId, x')+++-- | Generate a new session id and sends a cookie to the client. The+-- input signal specifies the validity duration. If 'Nothing', then the+-- session is valid for the duration of the browser session.++setNewSessId :: WebWire site (Maybe NominalDiffTime) ByteString+setNewSessId =+ proc validity -> do+ sessId <- genSessId -< ()+ setCookieSimple -< ("SESSION", B64.encode sessId, validity)+ identity -< sessId
+ WebWire/Tools.hs view
@@ -0,0 +1,111 @@+-- |+-- Module: WebWire.Tools+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Various webwire tools.++module WebWire.Tools+ ( -- * Requests+ getQueryParam,++ -- * Responses+ -- ** Headers+ addHeader,++ -- ** Cookies+ getCookie,+ setCookie,+ setCookieSimple,++ -- ** Failure+ notFound+ )+ where++import qualified Data.Map as M+import Blaze.ByteString.Builder+import Control.Arrow+import Control.Exception+import Control.Monad.Trans.State+import Data.ByteString as B+import Data.CaseInsensitive+import Data.Time.Clock+import FRP.NetWire+import Network.HTTP.Types+import Web.Cookie+import WebWire.Types+++-- | Add an additional header to the response.++addHeader :: WebWire site (CI Ascii, Ascii) ()+addHeader =+ proc h ->+ execute -< modify $ \cfg ->+ let h' = wcSetHeaders cfg+ in cfg { wcSetHeaders = h : h' }+++-- | Retrieves the given cookie from the request. Inhibits, if the+-- cookie doesn't exist.++getCookie :: WebWire site ByteString ByteString+getCookie =+ proc name -> do+ cookies <- execute -< gets wcCookies+ case M.lookup name cookies of+ Just value -> identity -< value+ Nothing -> notFound -< ()+++-- | Retrieve the given query parameter. Inhibits with 404, if the+-- parameter does not exist.++getQueryParam :: WebWire site ByteString ByteString+getQueryParam =+ proc name -> do+ params <- execute -< gets wcQueryParams+ case M.lookup name params of+ Nothing -> notFound -< ()+ Just value -> identity -< value+++-- | Inhibits with a 404 error.++notFound :: WebWire site a b+notFound =+ constant (toException (WebException statusNotFound)) >>>+ inhibit+++-- | Sets the given cookie.++setCookie :: WebWire site SetCookie ()+setCookie =+ proc cookie ->+ execute -< modify $ \cfg ->+ let cs' = wcSetCookies cfg+ cStr = toByteString (renderSetCookie cookie)+ in cfg { wcSetCookies = M.insert (setCookieName cookie) cStr cs' }+++-- | Sets the given cookie for the root path of the current domain with+-- the given validity duration. If no duration is given, it becomes a+-- session cookie.++setCookieSimple :: WebWire site (ByteString, ByteString, Maybe NominalDiffTime) ()+setCookieSimple =+ proc (name, value, mTime) -> do+ let cookie = SetCookie { setCookieName = name,+ setCookieValue = value,+ setCookiePath = Just "/",+ setCookieExpires = Nothing,+ setCookieDomain = Nothing,+ setCookieHttpOnly = False }+ case mTime of+ Nothing -> setCookie -< cookie+ Just dt -> do+ now <- execute -< liftIO getCurrentTime+ setCookie -< cookie { setCookieExpires = Just (addUTCTime dt now) }
+ WebWire/Types.hs view
@@ -0,0 +1,118 @@+-- |+-- Module: WebWire.Types+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Types used in webwire.++module WebWire.Types+ ( -- * Common types+ WebException(..),+ WebOutput(..),+ WebWire,++ -- * Utility types+ RedirectType(..),++ -- * Simple sites+ SimpleWire,++ -- * Internal+ WebConfig(..)+ )+ where++import qualified Data.ByteString.Char8 as BC+import qualified Data.Text as T+import Blaze.ByteString.Builder+import Control.Exception+import Control.Monad.Trans.State+import Data.ByteString (ByteString)+import Data.CaseInsensitive (CI)+import Data.Map (Map)+import Data.Text (Text)+import Data.Typeable+import FRP.NetWire+import Network.HTTP.Types+import Network.Wai+import Network.Wai.Parse+import Text.Blaze+import WebWire.Widget+++-- | Types of redirection. For temporary redirections, especially in+-- response to handling a form, you will want to use 'RedirectSeeOther'.++data RedirectType+ = RedirectPermanent -- ^ Permanently moved (301).+ | RedirectSeeOther -- ^ See other (303).+ | RedirectTemporary -- ^ Temporary redirection (307).+++-- | Wire type for simple sites.++type SimpleWire = WebWire ()+++-- | Runtime configuration of a wire.++data WebConfig site =+ WebConfig {+ wcCookies :: Map ByteString ByteString, -- ^ Received cookies.+ wcCurrentPath :: [Text], -- ^ Current path.+ wcPostParams :: Map ByteString ByteString, -- ^ POST parameters.+ wcPostFiles :: Map ByteString (FileInfo FilePath), -- ^ POST files.+ wcQueryParams :: Map ByteString ByteString, -- ^ Query parameters.+ wcRequest :: Request, -- ^ Current request.+ wcRequestPath :: [Text], -- ^ Request path.+ wcRootPath :: [Text], -- ^ Site's root path.+ wcSetCookies :: Map ByteString ByteString, -- ^ Cookies to add to the response.+ wcSetHeaders :: [(CI Ascii, Ascii)], -- ^ Headers to add to the response.+ wcSite :: site, -- ^ User site argument.+ wcWidget :: Widget -- ^ Default rendering widget.+ }+++-- | A web exception is an HTTP status code possibly with additional+-- data.++data WebException+ -- | Generic web exception. This can be an internal server error+ -- (5xx) or document error (4xx), which don't need additional data.+ = WebException Status++ -- | Redirection exception. The second argument specifies the URI+ -- to redirect to.+ | WebRedirect Status Text+ deriving (Typeable)++instance Show WebException where+ show (WebException (Status code msg)) =+ show code ++ ": " ++ BC.unpack msg++ show (WebRedirect (Status code msg) uri) =+ show code ++ ": " ++ BC.unpack msg ++ " <" ++ T.unpack uri ++ ">"++instance Exception WebException+++-- | Various output types. The boolean argument taken by the+-- constructors specifies whether a Content-length header should be+-- sent. If true, the string will be fully built, before being sent to+-- the client.++data WebOutput+ -- | Generic data output+ = GenOutput Bool Ascii Builder++ -- | UTF-8-encoded HTML.+ | HtmlOutput Bool Html++ -- | UTF-8-encoded string.+ | TextOutput Bool Builder+++-- | Web request handling wires.++type WebWire site = Wire (StateT (WebConfig site) IO)
+ WebWire/Widget.hs view
@@ -0,0 +1,162 @@+-- |+-- Module: WebWire.Widget+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- HTML widgets, inspired by Yesod.++module WebWire.Widget+ ( -- * Widget type+ Widget(..),++ -- * Adding content+ bodyW,+ hamletW,+ titleW,++ -- * Stylesheets+ cassiusW,+ cssLinkW,+ cssW,++ -- * JavaScript+ jsLinkW,+ jsW,+ juliusW+ )+ where++import qualified Text.Blaze.Html5 as He+import qualified Text.Blaze.Html5.Attributes as Ha+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Monoid+import Data.Text (Text)+import Text.Blaze+import Text.Cassius+import Text.Hamlet+import Text.Julius+++-- | A widget is essentially a full HTML page splitted into the actual+-- HTML markup and its dependencies like CSS and JavaScript.++data Widget =+ Widget {+ wgtBody :: Html, -- ^ HTML body.+ wgtHeadCSS :: [TL.Text], -- ^ CSS source code to add.+ wgtHeadJS :: [TL.Text], -- ^ JavaScript source code to add.+ wgtLinkCSS :: [Text], -- ^ CSS links to add.+ wgtLinkJS :: [Text], -- ^ JavaScript links to add.+ wgtTitle :: [Text] -- ^ Page title parts.+ }+++-- | The empty widget is an HTML page with an empty body and no+-- dependencies. The sum of two widgets is the concatenation of the+-- individual HTML markups and the union of their dependencies, such+-- that external stylesheets or JavaScript files are only included once.++instance Monoid Widget where+ mempty =+ Widget { wgtBody = mempty,+ wgtHeadCSS = [],+ wgtHeadJS = [],+ wgtLinkCSS = [],+ wgtLinkJS = [],+ wgtTitle = [] }++ mappend w1 w2 =+ let ws = [w1, w2] in+ Widget { wgtBody = mappend (wgtBody w1) (wgtBody w2),+ wgtHeadCSS = concatMap wgtHeadCSS ws,+ wgtHeadJS = concatMap wgtHeadJS ws,+ wgtLinkCSS = concatMap wgtLinkCSS ws,+ wgtLinkJS = concatMap wgtLinkJS ws,+ wgtTitle = concatMap wgtTitle ws }+++-- | A widget can be converted into HTML with a default page template.+-- This should suffice for simple websites.++instance ToHtml Widget where+ toHtml w =+ let title = T.intercalate ": " (wgtTitle w)+ linkCSS =+ mconcat .+ map (\ref -> He.link ! Ha.rel "stylesheet" ! Ha.type_ "text/css" ! Ha.href (toValue ref)) .+ wgtLinkCSS $ w+ linkJS =+ mconcat .+ map (\ref -> He.script mempty ! Ha.type_ "text/javascript" ! Ha.src (toValue ref)) .+ wgtLinkJS $ w+ headCSS =+ mconcat .+ map (\src -> He.style (toHtml src) ! Ha.type_ "text/css") .+ wgtHeadCSS $ w+ headJS =+ mconcat .+ map (\src -> He.script (toHtml src) ! Ha.type_ "text/javascript") .+ wgtHeadJS $ w+ in+ He.docType `mappend`+ He.head (+ He.title (toHtml title) `mappend`+ linkCSS `mappend` linkJS `mappend`+ headCSS `mappend` headJS) `mappend`+ He.body (wgtBody w)+++-- | Widget with an HTML body fragment.++bodyW :: Html -> Widget+bodyW html = mempty { wgtBody = html }+++-- | Widget with an inline CSS stylesheet rendered by Cassius or Lucius.++cassiusW :: CssUrl a -> Widget+cassiusW cass = mempty { wgtHeadCSS = [renderCss $ cass (\_ _ -> "/")] }+++-- | Widget with an external CSS link.++cssLinkW :: Text -> Widget+cssLinkW src = mempty { wgtLinkCSS = [src] }+++-- | Widget with an inline CSS stylesheet.++cssW :: TL.Text -> Widget+cssW src = mempty { wgtHeadCSS = [src] }+++-- | Widget with an HTML body fragment from Hamlet.++hamletW :: HtmlUrl a -> Widget+hamletW html = mempty { wgtBody = html (\_ _ -> "/") }+++-- | Widget with an external JavaScript link.++jsLinkW :: Text -> Widget+jsLinkW src = mempty { wgtLinkJS = [src] }+++-- | Widget with inline JavaScript.++jsW :: TL.Text -> Widget+jsW src = mempty { wgtHeadJS = [src] }+++-- | Widget with inline JavaScript rendered by Julius.++juliusW :: JavascriptUrl a -> Widget+juliusW js = mempty { wgtHeadJS = [renderJavascript $ js (\_ _ -> "/")] }+++-- | Widget with a title segment.++titleW :: Text -> Widget+titleW title = mempty { wgtTitle = [title] }
+ webwire.cabal view
@@ -0,0 +1,76 @@+Name: webwire+Version: 0.1.0+Category: Web+Synopsis: Functional reactive web framework+Maintainer: Ertugrul Söylemez <es@ertes.de>+Author: Ertugrul Söylemez <es@ertes.de>+Copyright: (c) 2011 Ertugrul Söylemez+License: BSD3+License-file: LICENSE+Build-type: Simple+Stability: experimental+Cabal-version: >= 1.8+Description:+ Web framework based on the design pattern of functional reactive+ programming (FRP) using the netwire library.++Library+ Build-depends:+ base >= 4 && < 5,+ base64-bytestring >= 0.1.0,+ blaze-builder >= 0.3.0,+ blaze-html >= 0.4.1,+ bytestring >= 0.9.1,+ case-insensitive >= 0.3.0,+ containers >= 0.4.0,+ cookie >= 0.3.0,+ cprng-aes >= 0.2.1,+ hamlet >= 0.10.0,+ http-types >= 0.6.5,+ netwire >= 1.2.5,+ shakespeare-css >= 0.10.1,+ shakespeare-js >= 0.10.1,+ text >= 0.11.1,+ time >= 1.2.0,+ transformers >= 0.2.2,+ wai >= 0.4.1,+ wai-extra >= 0.4.2+ Extensions:+ Arrows+ DeriveDataTypeable+ DoRec+ FlexibleInstances+ OverloadedStrings+ ScopedTypeVariables+ TupleSections+ TypeSynonymInstances+ GHC-Options: -W+ Exposed-modules:+ WebWire+ WebWire.Core+ WebWire.Render+ WebWire.Routing+ WebWire.Session+ WebWire.Tools+ WebWire.Types+ WebWire.Widget++-- Executable webwire-test+-- Build-depends:+-- base >= 4 && < 5,+-- blaze-html,+-- bytestring,+-- hamlet,+-- shakespeare-css,+-- shakespeare-js,+-- text,+-- time,+-- warp,+-- webwire+-- Extensions:+-- Arrows+-- OverloadedStrings+-- QuasiQuotes+-- Hs-source-dirs: test+-- Main-is: Main.hs+-- GHC-Options: -W -threaded -rtsopts