diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/WebWire.hs b/WebWire.hs new file mode 100644 --- /dev/null +++ b/WebWire.hs @@ -0,0 +1,33 @@ +-- | +-- Module: WebWire +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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 diff --git a/WebWire/Core.hs b/WebWire/Core.hs new file mode 100644 --- /dev/null +++ b/WebWire/Core.hs @@ -0,0 +1,126 @@ +-- | +-- Module: WebWire.Core +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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) diff --git a/WebWire/Render.hs b/WebWire/Render.hs new file mode 100644 --- /dev/null +++ b/WebWire/Render.hs @@ -0,0 +1,163 @@ +-- | +-- Module: WebWire.Render +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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) diff --git a/WebWire/Routing.hs b/WebWire/Routing.hs new file mode 100644 --- /dev/null +++ b/WebWire/Routing.hs @@ -0,0 +1,232 @@ +-- | +-- Module: WebWire.Routing +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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 }) diff --git a/WebWire/Session.hs b/WebWire/Session.hs new file mode 100644 --- /dev/null +++ b/WebWire/Session.hs @@ -0,0 +1,115 @@ +-- | +-- Module: WebWire.Session +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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 diff --git a/WebWire/Tools.hs b/WebWire/Tools.hs new file mode 100644 --- /dev/null +++ b/WebWire/Tools.hs @@ -0,0 +1,111 @@ +-- | +-- Module: WebWire.Tools +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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) } diff --git a/WebWire/Types.hs b/WebWire/Types.hs new file mode 100644 --- /dev/null +++ b/WebWire/Types.hs @@ -0,0 +1,118 @@ +-- | +-- Module: WebWire.Types +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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) diff --git a/WebWire/Widget.hs b/WebWire/Widget.hs new file mode 100644 --- /dev/null +++ b/WebWire/Widget.hs @@ -0,0 +1,162 @@ +-- | +-- Module: WebWire.Widget +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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] } diff --git a/webwire.cabal b/webwire.cabal new file mode 100644 --- /dev/null +++ b/webwire.cabal @@ -0,0 +1,76 @@ +Name: webwire +Version: 0.1.0 +Category: Web +Synopsis: Functional reactive web framework +Maintainer: Ertugrul Söylemez +Author: Ertugrul Söylemez +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