webwire-0.1.0: WebWire/Core.hs

-- |
-- 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)