webwire-0.1.0: WebWire/Tools.hs

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