{-# LANGUAGE DeriveDataTypeable #-}-- http://tools.ietf.org/html/rfc2109moduleHappstack.Server.Internal.Cookie(Cookie(..),CookieLife(..),calcLife,mkCookie,mkCookieHeader,getCookies,getCookie,getCookies',getCookie',parseCookies,cookiesParser)whereimportControl.Applicative((<$>))importqualifiedData.ByteString.Char8asCimportData.Char(chr,toLower)importData.Data(Data,Typeable)importData.List((\\),intersperse)importData.Time.Clock(UTCTime,addUTCTime,diffUTCTime)importData.Time.Clock.POSIX(posixSecondsToUTCTime)importData.Time.Format(formatTime)importHappstack.Util.Common(Seconds)importHappstack.Server.Internal.Clock(getApproximateUTCTime)importText.ParserCombinators.Parsechiding(token)importSystem.Locale(defaultTimeLocale)-- | a type for HTTP cookies. Usually created using 'mkCookie'.dataCookie=Cookie{cookieVersion::String,cookiePath::String,cookieDomain::String,cookieName::String,cookieValue::String,secure::Bool}deriving(Show,Eq,Read,Typeable,Data)-- | Specify the lifetime of a cookie.---- Note that we always set the max-age and expires headers because-- internet explorer does not honor max-age. You can specific 'MaxAge'-- or 'Expires' and the other will be calculated for you. Choose which-- ever one makes your life easiest.--dataCookieLife=Session-- ^ session cookie - expires when browser is closed|MaxAgeSeconds-- ^ life time of cookie in seconds|ExpiresUTCTime-- ^ cookie expiration date|Expired-- ^ cookie already expiredderiving(Eq,Ord,Read,Show,Typeable)-- convert 'CookieLife' to the argument needed for calling 'mkCookieHeader'calcLife::CookieLife->IO(Maybe(Seconds,UTCTime))calcLifeSession=returnNothingcalcLife(MaxAges)=donow<-getApproximateUTCTimereturn(Just(s,addUTCTime(fromIntegrals)now))calcLife(ExpiresexpirationDate)=donow<-getApproximateUTCTimereturn$Just(round$expirationDate`diffUTCTime`now,expirationDate)calcLifeExpired=return$Just(0,posixSecondsToUTCTime0)-- | Creates a cookie with a default version of 1, empty domain, a path of "/", and secure == False---- see also: 'addCookie'mkCookie::String-- ^ cookie name->String-- ^ cookie value->CookiemkCookiekeyval=Cookie"1""/"""keyvalFalse-- | Set a Cookie in the Result.-- The values are escaped as per RFC 2109, but some browsers may-- have buggy support for cookies containing e.g. @\'\"\'@ or @\' \'@.---- Also, it seems that chrome, safari, and other webkit browsers do-- not like cookies which have double quotes around the domain and-- reject/ignore the cookie. So, we no longer quote the domain.---- internet explorer does not honor the max-age directive so we set-- both max-age and expires.---- See 'CookieLife' and 'calcLife' for a convenient way of calculating-- the first argument to this function.mkCookieHeader::Maybe(Seconds,UTCTime)->Cookie->StringmkCookieHeadermLifecookie=letl=[("Domain=",cookieDomaincookie),("Max-Age=",maybe""(show.max0.fst)mLife),("expires=",maybe""(formatTimedefaultTimeLocale"%a, %d-%b-%Y %X GMT".snd)mLife),("Path=",cookiePathcookie),("Version=",scookieVersion)]sf|fcookie==""=""sf='\"':concatMape(fcookie)++"\""ec|fctlc||c=='"'=['\\',c]|otherwise=[c]inconcat$intersperse";"((cookieNamecookie++"="++scookieValue):[(k++v)|(k,v)<-l,""/=v]++ifsecurecookiethen["Secure"]else[])fctl::Char->Boolfctlch=ch==chr127||ch<=chr31-- | Not an supported api. Takes a cookie header and returns-- either a String error message or an array of parsed cookiesparseCookies::String->EitherString[Cookie]parseCookiesstr=either(Left.show)Right$parsecookiesParserstrstr-- | not a supported api. A parser for RFC 2109 cookiescookiesParser::GenParserCharst[Cookie]cookiesParser=cookieswhere-- Parsers based on RFC 2109cookies=dowsver<-option""$try(cookie_version>>=(\x->cookieSep>>returnx))cookieList<-(cookie_valuever)`sepBy1`trycookieSepwseofreturncookieListcookie_valuever=doname<-name_parsercookieEqval<-valuepath<-option""$try(cookieSep>>cookie_path)domain<-option""$try(cookieSep>>cookie_domain)return$Cookieverpathdomain(lowname)valFalsecookie_version=cookie_special"$Version"cookie_path=cookie_special"$Path"cookie_domain=cookie_special"$Domain"cookie_specials=dostringscookieEqvaluecookieSep=ws>>oneOf",;">>wscookieEq=ws>>char'='>>wsws=spacesvalue=wordword=try(quoted_string)<|>incomp_token-- Parsers based on RFC 2068quoted_string=dochar'"'r<-many(oneOfqdtext)char'"'returnr-- Custom parsers, incompatible with RFC 2068, but more forgiving ;)incomp_token=many1$oneOf((chars\\ctl)\\" \t\";")name_parser=many1$oneOf((chars\\ctl)\\"= ;,")-- Primitives from RFC 2068ctl=mapchr(127:[0..31])chars=mapchr[0..127]octet=mapchr[0..255]text=octet\\ctlqdtext=text\\"\""-- | Get all cookies from the HTTP request. The cookies are ordered per RFC from-- the most specific to the least specific. Multiple cookies with the same-- name are allowed to exist.getCookies::Monadm=>C.ByteString->m[Cookie]getCookiesh=getCookies'h>>=either(fail.("Cookie parsing failed!"++))return-- | Get the most specific cookie with the given name. Fails if there is no such-- cookie or if the browser did not escape cookies in a proper fashion.-- Browser support for escaping cookies properly is very diverse.getCookie::Monadm=>String->C.ByteString->mCookiegetCookiesh=getCookie'sh>>=either(const$fail("getCookie: "++shows))returngetCookies'::Monadm=>C.ByteString->m(EitherString[Cookie])getCookies'header|C.nullheader=return$Right[]|otherwise=return$parseCookies(C.unpackheader)getCookie'::Monadm=>String->C.ByteString->m(EitherStringCookie)getCookie'sh=docs<-getCookies'hreturn$do-- Eithercooks<-cscasefilter(\x->(==)(lows)(cookieNamex))cooksof[]->fail"No cookie found"f->return$headflow::String->Stringlow=maptoLower