Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 2a93e469db
Fetching contributors…

Cannot retrieve contributors at this time

executable file 136 lines (118 sloc) 4.614 kb
-----------------------------------------------------------------------------
-- |
-- Module : Turbinado.Environment.Cookie
-- Copyright : (c) Alson Kemp 2008-2009
-- (c) Bjorn Bringert 2004-2005
-- (c) Ian Lynagh 2005
-- License : BSD-style
--
-- Maintainer : alson@alsonkemp.com
-- Stability : experimental
-- Portability : portable
--
-- General server side HTTP cookie library.
-- Based on <http://wp.netscape.com/newsref/std/cookie_spec.html>
-- Lifted in near entirety from the CGI package (http://hackage.haskell.org/cgi-bin/hackage-scripts/package/cgi)
--
-----------------------------------------------------------------------------
module Turbinado.Environment.Cookie
( mkCookie
, getCookie
, setCookie
, deleteCookie
, showCookie
) where
import Data.Char (isSpace)
import Data.List (intercalate)
import Data.Maybe (catMaybes)
import System.Locale (defaultTimeLocale, rfc822DateFormat)
import Data.Time
import Network.HTTP.Headers
import Turbinado.Environment.Header
import Turbinado.Environment.Response
import Turbinado.Environment.Types
import Turbinado.Utility.Data (fromJust')
--
-- * Getting cookies
--
-- | Get the value of a cookie from a string on the form
-- @\"cookieName1=cookieValue1;...;cookieName2=cookieValue2\"@.
-- This is the format of the @Cookie@ HTTP header.
getCookie :: HasEnvironment m =>
String -- ^ Cookie name
-> m (Maybe String) -- ^ Cookie value, if found
getCookie name = do e <- getEnvironment
h <- getHeader HdrCookie
case h of
Nothing -> return Nothing
Just h' -> return $ maybeLast [ cv | (cn,cv) <- readCookies h', cn == name ]
--
-- * Setting Cookies
--
-- | Set a cookie (which you should have created using something like 'mkCookie'
setCookie :: HasEnvironment m =>
Cookie ->
m ()
setCookie c = do e <- getEnvironment
let r = fromJust' "setCookie" $ getResponse e
setResponse $ insertHeaders [Header HdrSetCookie $ showCookie c] r
-- | Construct a cookie with only name and value set.
-- This client will expire when the browser sessions ends,
-- will only be sent to the server and path which set it
-- and may be sent using any means.
mkCookie :: String -- ^ Name
-> String -- ^ Value
-> Cookie -- ^ Cookie
mkCookie name value = Cookie { cookieName = name,
cookieValue = value,
cookieExpires = Nothing,
cookieDomain = Nothing,
cookiePath = Nothing
}
-- | Delete a cookie from the client by setting the cookie expiry date
-- to a date in the past.
deleteCookie :: HasEnvironment m =>
String -- ^ Cookie to delete.
-> m ()
deleteCookie c = setCookie $ c' { cookieExpires = Just epoch }
where
c' = mkCookie c ""
epoch = UTCTime (ModifiedJulianDay 100) (secondsToDiffTime 0)
--
-- * Showing cookies
--
-- | Show a cookie in the format used as the value of the Set-Cookie header.
showCookie :: Cookie -> String
showCookie c = intercalate "; " $
showPair (cookieName c) (cookieValue c)
: catMaybes [expires, path, domain]
where expires = fmap (showPair "expires" . dateFmt) (cookieExpires c)
domain = fmap (showPair "domain") (cookieDomain c)
path = fmap (showPair "path") (maybe (Just "/") Just (cookiePath c))
dateFmt = formatTime defaultTimeLocale "%a, %d-%b-%Y %H:%M:%S GMT"
--
-- * Reading cookies
--
-- | Gets all the cookies from a Cookie: header value
readCookies :: String -- ^ String to parse
-> [(String,String)] -- ^ Cookie name - cookie value pairs
readCookies s =
let (xs,ys) = break (=='=') (dropWhile isSpace s)
(zs,ws) = break (==';') (dropWhile isSpace (drop 1 ys))
in if null xs then [] else (xs,zs):readCookies (drop 1 ws)
--
-- * Utilities
--
-- | Return 'Nothing' is the list is empty, otherwise return
-- the last element of the list.
maybeLast :: [a] -> Maybe a
maybeLast [] = Nothing
maybeLast xs = Just (last xs)
-- | Show a name-value pair. FIXME: if the name or value
-- contains semicolons, this breaks. The problem
-- is that the original cookie spec does not mention
-- how to do escaping or quoting.
showPair :: String -- ^ name
-> String -- ^ value
-> String
showPair name value = name ++ "=" ++ value
Jump to Line
Something went wrong with that request. Please try again.