module WebWire.Tools
(
getQueryParam,
addHeader,
getCookie,
setCookie,
setCookieSimple,
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
addHeader :: WebWire site (CI Ascii, Ascii) ()
addHeader =
proc h ->
execute -< modify $ \cfg ->
let h' = wcSetHeaders cfg
in cfg { wcSetHeaders = h : h' }
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 -< ()
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
notFound :: WebWire site a b
notFound =
constant (toException (WebException statusNotFound)) >>>
inhibit
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' }
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) }