{-# LANGUAGE DeriveDataTypeable #-}
-- http://tools.ietf.org/html/rfc2109
module HAppS.Server.Cookie
( Cookie(..), mkCookie, mkCookieHeader
, getCookies, getCookie )
where
import qualified Data.ByteString.Char8 as C
import Data.Char
import Data.List
import Data.Generics
import HAppS.Util.Common (Seconds)
import Text.ParserCombinators.ReadP
data Cookie = Cookie
{ cookieVersion :: String
, cookiePath :: String
, cookieDomain :: String
, cookieName :: String
, cookieValue :: String
} deriving(Show,Eq,Read,Typeable,Data)
mkCookie :: String -> String -> Cookie
mkCookie key val = Cookie "1" "/" "" key val
-- | 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 @\' \'@.
mkCookieHeader :: Seconds -> Cookie -> String
mkCookieHeader sec cookie =
let l = [("Domain=",s cookieDomain)
,("Max-Age=",if sec < 0 then "" else show sec)
,("Path=", cookiePath cookie)
,("Version=", s cookieVersion)]
s f | f cookie == "" = ""
s f = '\"' : concatMap e (f cookie) ++ "\""
e c | fctl c || c == '"' = ['\\',c]
| otherwise = [c]
in concat $ intersperse ";" ((cookieName cookie++"="++s cookieValue):[ (k++v) | (k,v) <- l, "" /= v ])
{- Cookie syntax:
av-pairs = av-pair *(";" av-pair)
av-pair = attr ["=" value] ; optional value
attr = token
value = word
word = token | quoted-string
-}
gmany :: ReadP a -> ReadP [a]
gmany p = gmany1 p <++ return []
gmany1 :: ReadP a -> ReadP [a]
gmany1 p = do x <- p
xs <- gmany1 p <++ return []
return (x:xs)
gskipMany1 :: ReadP a -> ReadP ()
gskipMany1 p = p >> (gskipMany p <++ return ())
gskipMany :: ReadP a -> ReadP ()
gskipMany p = gskipMany1 p <++ return ()
fctl :: Char -> Bool
fctl = \ch -> ch == chr 127 || ch <= chr 31
fseparator :: Char -> Bool
fseparator = \ch -> ch `elem` "()<>@,;:\\\"[]?={} \t" -- ignore '/' here
fchar :: Char -> Bool
fchar = \ch -> ch <= chr 127
ftoken :: Char -> Bool
ftoken = \ch -> fchar ch && not (fctl ch || fseparator ch)
lws :: ReadP ()
lws = ((char '\r' >> char '\n') <++ return ' ') >> gskipMany (satisfy (\ch -> ch == ' ' || ch == '\t'))
token :: ReadP [Char]
token = gmany $ satisfy ftoken
quotedString :: ReadP [Char]
quotedString = do char '"' -- " stupid emacs syntax highlighting
x <- many ((char '\\' >> satisfy fchar) <++ (satisfy $ \ch -> ch /= '"' && fchar ch && (ch == ' ' || ch == '\t' || not (fctl ch))))
char '"' -- " stupid emacs syntax highlighting
return x
word :: ReadP [Char]
word = quotedString <++ token
avPair :: ReadP (String, [Char])
avPair = do
k <- token
lws >> char '=' >> lws
v <- word
return (low k,v)
sep :: ReadP ()
sep = lws >> satisfy (\ch -> ch == ',' || ch == ';') >> lws
cookies :: ReadP [Cookie]
cookies = do
let kpw n = do lws
(k,v) <- avPair
if k == n then return v else fail "Invalid key"
ver <- ((kpw "$version" <~ sep) <++ return "")
let ci = do (k,v) <- avPair
p <- (sep >> kpw "$path") <++ return ""
d <- (sep >> kpw "$domain") <++ return ""
return $ Cookie ver p d k v
x <- lws >> ci
xs <- gmany (sep >> ci) <~ lws
return (x:xs)
(<~) :: Monad m => m a -> m b -> m a
(<~) a b = do x <- a; b; return x
parse :: Monad m => String -> m [Cookie]
parse i = case readP_to_S cookies i of
[(res,"")] -> return res
xs -> fail ("Invalid cookie syntax!: at position "++show (length i - length xs)++" input "++show i)
-- | 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 :: Monad m => C.ByteString -> m [Cookie]
getCookies header | C.null header = return []
| otherwise = parse (C.unpack header)
-- | 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 :: Monad m => String -> C.ByteString -> m Cookie
getCookie s h = do cs <- getCookies h
case filter ((==) (low s) . cookieName) cs of
[r] -> return r
_ -> fail ("getCookie: " ++ show s)
low :: String -> String
low = map toLower