module WebWire.Core
(
webWire,
simpleWire,
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
simpleError :: WebWire site Status Response
simpleError =
proc status@(Status code msg) ->
identity -<
ResponseBuilder
status
[headerContentType "text/plain"]
(mconcat [fromString (show code),
fromByteString ": ",
fromByteString msg])
simpleWire :: (Application -> IO a) -> SimpleWire () Response -> IO a
simpleWire run = webWire run ()
webWire ::
forall a site.
(Application -> IO a)
-> site
-> WebWire site () Response
-> IO a
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)