-----------------------------------------------------------------------------
-- |
-- Module      :  Network.HTTP.Cookie
-- Copyright   :  See LICENSE file
-- License     :  BSD
-- 
-- Maintainer  :  Ganesh Sittampalam <ganesh@earth.li>
-- Stability   :  experimental
-- Portability :  non-portable (not tested)
--
-- This module provides the data types and functions for working with HTTP cookies.
-- Right now, it contains mostly functionality needed by 'Network.Browser'.
-- 
-----------------------------------------------------------------------------
module Network.HTTP.Cookie
       ( Cookie(..)
       , cookieMatch          -- :: (String,String) -> Cookie -> Bool

          -- functions for translating cookies and headers.
       , cookiesToHeader      -- :: [Cookie] -> Header
       , processCookieHeaders -- :: String -> [Header] -> ([String], [Cookie])
       ) where

import Network.HTTP.Headers

import Data.Char
import Data.List
import Data.Maybe

import Text.ParserCombinators.Parsec
   ( Parser, char, many, many1, satisfy, parse, option, try
   , (<|>), sepBy1
   )

------------------------------------------------------------------
----------------------- Cookie Stuff -----------------------------
------------------------------------------------------------------

-- | @Cookie@ is the Haskell representation of HTTP cookie values.
-- See its relevant specs for authoritative details.
data Cookie 
 = MkCookie 
    { Cookie -> String
ckDomain  :: String
    , Cookie -> String
ckName    :: String
    , Cookie -> String
ckValue   :: String
    , Cookie -> Maybe String
ckPath    :: Maybe String
    , Cookie -> Maybe String
ckComment :: Maybe String
    , Cookie -> Maybe String
ckVersion :: Maybe String
    }
    deriving(Int -> Cookie -> ShowS
[Cookie] -> ShowS
Cookie -> String
(Int -> Cookie -> ShowS)
-> (Cookie -> String) -> ([Cookie] -> ShowS) -> Show Cookie
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Cookie] -> ShowS
$cshowList :: [Cookie] -> ShowS
show :: Cookie -> String
$cshow :: Cookie -> String
showsPrec :: Int -> Cookie -> ShowS
$cshowsPrec :: Int -> Cookie -> ShowS
Show,ReadPrec [Cookie]
ReadPrec Cookie
Int -> ReadS Cookie
ReadS [Cookie]
(Int -> ReadS Cookie)
-> ReadS [Cookie]
-> ReadPrec Cookie
-> ReadPrec [Cookie]
-> Read Cookie
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Cookie]
$creadListPrec :: ReadPrec [Cookie]
readPrec :: ReadPrec Cookie
$creadPrec :: ReadPrec Cookie
readList :: ReadS [Cookie]
$creadList :: ReadS [Cookie]
readsPrec :: Int -> ReadS Cookie
$creadsPrec :: Int -> ReadS Cookie
Read)

instance Eq Cookie where
    Cookie
a == :: Cookie -> Cookie -> Bool
== Cookie
b  =  Cookie -> String
ckDomain Cookie
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Cookie -> String
ckDomain Cookie
b 
            Bool -> Bool -> Bool
&& Cookie -> String
ckName Cookie
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Cookie -> String
ckName Cookie
b 
            Bool -> Bool -> Bool
&& Cookie -> Maybe String
ckPath Cookie
a Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Cookie -> Maybe String
ckPath Cookie
b

-- | @cookieToHeaders ck@ serialises @Cookie@s to an HTTP request header.
cookiesToHeader :: [Cookie] -> Header
cookiesToHeader :: [Cookie] -> Header
cookiesToHeader [Cookie]
cs = HeaderName -> String -> Header
Header HeaderName
HdrCookie ([Cookie] -> String
mkCookieHeaderValue [Cookie]
cs)

-- | Turn a list of cookies into a key=value pair list, separated by
-- semicolons.
mkCookieHeaderValue :: [Cookie] -> String
mkCookieHeaderValue :: [Cookie] -> String
mkCookieHeaderValue = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"; " ([String] -> String)
-> ([Cookie] -> [String]) -> [Cookie] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cookie -> String) -> [Cookie] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Cookie -> String
mkCookieHeaderValue1
  where
    mkCookieHeaderValue1 :: Cookie -> String
mkCookieHeaderValue1 Cookie
c = Cookie -> String
ckName Cookie
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Cookie -> String
ckValue Cookie
c

-- | @cookieMatch (domain,path) ck@ performs the standard cookie
-- match wrt the given domain and path. 
cookieMatch :: (String, String) -> Cookie -> Bool
cookieMatch :: (String, String) -> Cookie -> Bool
cookieMatch (String
dom,String
path) Cookie
ck =
 Cookie -> String
ckDomain Cookie
ck String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
dom Bool -> Bool -> Bool
&&
 case Cookie -> Maybe String
ckPath Cookie
ck of
   Maybe String
Nothing -> Bool
True
   Just String
p  -> String
p String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
path


-- | @processCookieHeaders dom hdrs@ 
processCookieHeaders :: String -> [Header] -> ([String], [Cookie])
processCookieHeaders :: String -> [Header] -> ([String], [Cookie])
processCookieHeaders String
dom [Header]
hdrs = (Header -> ([String], [Cookie]) -> ([String], [Cookie]))
-> ([String], [Cookie]) -> [Header] -> ([String], [Cookie])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (String -> Header -> ([String], [Cookie]) -> ([String], [Cookie])
headerToCookies String
dom) ([],[]) [Header]
hdrs

-- | @headerToCookies dom hdr acc@ 
headerToCookies :: String -> Header -> ([String], [Cookie]) -> ([String], [Cookie])
headerToCookies :: String -> Header -> ([String], [Cookie]) -> ([String], [Cookie])
headerToCookies String
dom (Header HeaderName
HdrSetCookie String
val) ([String]
accErr, [Cookie]
accCookie) = 
    case Parsec String () [Cookie]
-> String -> String -> Either ParseError [Cookie]
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec String () [Cookie]
cookies String
"" String
val of
        Left{}  -> (String
valString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
accErr, [Cookie]
accCookie)
        Right [Cookie]
x -> ([String]
accErr, [Cookie]
x [Cookie] -> [Cookie] -> [Cookie]
forall a. [a] -> [a] -> [a]
++ [Cookie]
accCookie)
  where
   cookies :: Parser [Cookie]
   cookies :: Parsec String () [Cookie]
cookies = ParsecT String () Identity Cookie
-> ParsecT String () Identity Char -> Parsec String () [Cookie]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepBy1 ParsecT String () Identity Cookie
cookie (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
',')

   cookie :: Parser Cookie
   cookie :: ParsecT String () Identity Cookie
cookie =
       do String
name <- Parser String
word
          String
_    <- Parser String
forall u. ParsecT String u Identity String
spaces_l
          Char
_    <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'='
          String
_    <- Parser String
forall u. ParsecT String u Identity String
spaces_l
          String
val1 <- Parser String
cvalue
          [(String, String)]
args <- Parser [(String, String)]
cdetail
          Cookie -> ParsecT String () Identity Cookie
forall (m :: * -> *) a. Monad m => a -> m a
return (Cookie -> ParsecT String () Identity Cookie)
-> Cookie -> ParsecT String () Identity Cookie
forall a b. (a -> b) -> a -> b
$ String -> String -> [(String, String)] -> Cookie
mkCookie String
name String
val1 [(String, String)]
args

   cvalue :: Parser String
   
   spaces_l :: ParsecT String u Identity String
spaces_l = ParsecT String u Identity Char -> ParsecT String u Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ((Char -> Bool) -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy Char -> Bool
isSpace)

   cvalue :: Parser String
cvalue = Parser String
quotedstring Parser String -> Parser String -> Parser String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String () Identity Char -> Parser String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ((Char -> Bool) -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy ((Char -> Bool) -> ParsecT String () Identity Char)
-> (Char -> Bool) -> ParsecT String () Identity Char
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
';')) Parser String -> Parser String -> Parser String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> String -> Parser String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
   
   -- all keys in the result list MUST be in lower case
   cdetail :: Parser [(String,String)]
   cdetail :: Parser [(String, String)]
cdetail = ParsecT String () Identity (String, String)
-> Parser [(String, String)]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (ParsecT String () Identity (String, String)
 -> Parser [(String, String)])
-> ParsecT String () Identity (String, String)
-> Parser [(String, String)]
forall a b. (a -> b) -> a -> b
$
       ParsecT String () Identity (String, String)
-> ParsecT String () Identity (String, String)
forall tok st a. GenParser tok st a -> GenParser tok st a
try (do String
_  <- Parser String
forall u. ParsecT String u Identity String
spaces_l
               Char
_  <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
';'
               String
_  <- Parser String
forall u. ParsecT String u Identity String
spaces_l
               String
s1 <- Parser String
word
               String
_  <- Parser String
forall u. ParsecT String u Identity String
spaces_l
               String
s2 <- String -> Parser String -> Parser String
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option String
"" (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'=' ParsecT String () Identity Char -> Parser String -> Parser String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser String
forall u. ParsecT String u Identity String
spaces_l Parser String -> Parser String -> Parser String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser String
cvalue)
               (String, String) -> ParsecT String () Identity (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s1,String
s2)
           )

   mkCookie :: String -> String -> [(String,String)] -> Cookie
   mkCookie :: String -> String -> [(String, String)] -> Cookie
mkCookie String
nm String
cval [(String, String)]
more = 
          MkCookie :: String
-> String
-> String
-> Maybe String
-> Maybe String
-> Maybe String
-> Cookie
MkCookie { ckName :: String
ckName    = String
nm
                   , ckValue :: String
ckValue   = String
cval
                   , ckDomain :: String
ckDomain  = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
dom (String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"domain" [(String, String)]
more))
                   , ckPath :: Maybe String
ckPath    = String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"path" [(String, String)]
more
                   , ckVersion :: Maybe String
ckVersion = String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"version" [(String, String)]
more
                   , ckComment :: Maybe String
ckComment = String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"comment" [(String, String)]
more
                   }
headerToCookies String
_ Header
_ ([String], [Cookie])
acc = ([String], [Cookie])
acc

      


word, quotedstring :: Parser String
quotedstring :: Parser String
quotedstring =
    do Char
_   <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"'  -- "
       String
str <- ParsecT String () Identity Char -> Parser String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ((Char -> Bool) -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy ((Char -> Bool) -> ParsecT String () Identity Char)
-> (Char -> Bool) -> ParsecT String () Identity Char
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'"'))
       Char
_   <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"'
       String -> Parser String
forall (m :: * -> *) a. Monad m => a -> m a
return String
str

word :: Parser String
word = ParsecT String () Identity Char -> Parser String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ((Char -> Bool) -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (\Char
x -> Char -> Bool
isAlphaNum Char
x Bool -> Bool -> Bool
|| Char
xChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'_' Bool -> Bool -> Bool
|| Char
xChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'.' Bool -> Bool -> Bool
|| Char
xChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'-' Bool -> Bool -> Bool
|| Char
xChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
':'))