-----------------------------------------------------------------------------
-- |
-- Module      :  Network.CGI.Cookie
-- Copyright   :  (c) Bjorn Bringert 2004-2005
--                (c) Ian Lynagh 2005
-- License     :  BSD-style
--
-- Maintainer  :  John Chee <cheecheeo@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
--  General server side HTTP cookie library.
--  Based on <http://wp.netscape.com/newsref/std/cookie_spec.html>
--
-- TODO
--
-- * Add client side stuff (basically parsing Set-Cookie: value)
--
-- * Update for RFC2109 <http://www.ietf.org/rfc/rfc2109.txt>
--
-----------------------------------------------------------------------------
module Network.CGI.Cookie (
                            Cookie(..)
                            , newCookie
                            , findCookie, deleteCookie
                            , showCookie, readCookies
                           ) where

import Data.Char (isSpace)
import Data.List (intercalate)
import Data.Maybe (catMaybes)
import Data.Time.Calendar (Day(..))
import Data.Time.Clock (UTCTime(..))
import Data.Time.Format (defaultTimeLocale, formatTime, rfc822DateFormat)

--
-- * Types
--

-- | Contains all information about a cookie set by the server.
data Cookie = Cookie {
                      -- | Name of the cookie.
                      Cookie -> String
cookieName :: String,
                      -- | Value of the cookie.
                      Cookie -> String
cookieValue :: String,
                      -- | Expiry date of the cookie. If 'Nothing', the
                      --   cookie expires when the browser sessions ends.
                      --   If the date is in the past, the client should
                      --   delete the cookie immediately.
                      Cookie -> Maybe UTCTime
cookieExpires :: Maybe UTCTime,
                      -- | The domain suffix to which this cookie will be sent.
                      Cookie -> Maybe String
cookieDomain :: Maybe String,
                      -- | The path to which this cookie will be sent.
                      Cookie -> Maybe String
cookiePath :: Maybe String,
                      -- | 'True' if this cookie should only be sent using
                      --   secure means.
                      Cookie -> Bool
cookieSecure :: Bool,
                      -- | 'True' to tell the client's browser to prevent
                      --   client side scripts from accessing the cookie.
                      Cookie -> Bool
cookieHttpOnly :: Bool
                     }
            deriving (Int -> Cookie -> ShowS
[Cookie] -> ShowS
Cookie -> String
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]
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, Cookie -> Cookie -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cookie -> Cookie -> Bool
$c/= :: Cookie -> Cookie -> Bool
== :: Cookie -> Cookie -> Bool
$c== :: Cookie -> Cookie -> Bool
Eq, Eq Cookie
Cookie -> Cookie -> Bool
Cookie -> Cookie -> Ordering
Cookie -> Cookie -> Cookie
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Cookie -> Cookie -> Cookie
$cmin :: Cookie -> Cookie -> Cookie
max :: Cookie -> Cookie -> Cookie
$cmax :: Cookie -> Cookie -> Cookie
>= :: Cookie -> Cookie -> Bool
$c>= :: Cookie -> Cookie -> Bool
> :: Cookie -> Cookie -> Bool
$c> :: Cookie -> Cookie -> Bool
<= :: Cookie -> Cookie -> Bool
$c<= :: Cookie -> Cookie -> Bool
< :: Cookie -> Cookie -> Bool
$c< :: Cookie -> Cookie -> Bool
compare :: Cookie -> Cookie -> Ordering
$ccompare :: Cookie -> Cookie -> Ordering
Ord)

--
-- * Constructing cookies
--

-- | 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.
newCookie :: String -- ^ Name
          -> String -- ^ Value
          -> Cookie -- ^ Cookie
newCookie :: String -> String -> Cookie
newCookie String
name String
value = Cookie { cookieName :: String
cookieName = String
name,
                                cookieValue :: String
cookieValue = String
value,
                                cookieExpires :: Maybe UTCTime
cookieExpires = forall a. Maybe a
Nothing,
                                cookieDomain :: Maybe String
cookieDomain = forall a. Maybe a
Nothing,
                                cookiePath :: Maybe String
cookiePath = forall a. Maybe a
Nothing,
                                cookieSecure :: Bool
cookieSecure = Bool
False,
                                cookieHttpOnly :: Bool
cookieHttpOnly = Bool
False
                              }

--
-- * Getting and setting 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.
findCookie :: String -- ^ Cookie name
           -> String -- ^ Semicolon separated list of name-value pairs
           -> Maybe String  -- ^ Cookie value, if found
findCookie :: String -> String -> Maybe String
findCookie String
name String
s = forall a. [a] -> Maybe a
maybeLast [ String
cv | (String
cn,String
cv) <- String -> [(String, String)]
readCookies String
s, String
cn forall a. Eq a => a -> a -> Bool
== String
name ]

-- | Delete a cookie from the client by setting the cookie expiry date
--   to a date in the past.
deleteCookie :: Cookie  -- ^ Cookie to delete. The only fields that matter
                        --   are 'cookieName', 'cookieDomain' and 'cookiePath'
             -> Cookie
deleteCookie :: Cookie -> Cookie
deleteCookie Cookie
c = Cookie
c { cookieExpires :: Maybe UTCTime
cookieExpires = forall a. a -> Maybe a
Just UTCTime
epoch }
    where
    epoch :: UTCTime
epoch = Day -> DiffTime -> UTCTime
UTCTime (Integer -> Day
ModifiedJulianDay Integer
40587) DiffTime
0

--
-- * Reading and showing cookies
--

-- | Show a cookie on the format used as the value of the Set-Cookie header.
showCookie :: Cookie -> String
showCookie :: Cookie -> String
showCookie Cookie
c = forall a. [a] -> [[a]] -> [a]
intercalate String
"; " forall a b. (a -> b) -> a -> b
$
                String -> ShowS
showPair (Cookie -> String
cookieName Cookie
c) (Cookie -> String
cookieValue Cookie
c)
                 forall a. a -> [a] -> [a]
: forall a. [Maybe a] -> [a]
catMaybes [Maybe String
expires, Maybe String
path, Maybe String
domain, Maybe String
secure, Maybe String
httpOnly]
    where expires :: Maybe String
expires = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> ShowS
showPair String
"expires" forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> String
dateFmt) (Cookie -> Maybe UTCTime
cookieExpires Cookie
c)
          domain :: Maybe String
domain = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> ShowS
showPair String
"domain") (Cookie -> Maybe String
cookieDomain Cookie
c)
          path :: Maybe String
path = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> ShowS
showPair String
"path") (Cookie -> Maybe String
cookiePath Cookie
c)
          secure :: Maybe String
secure = if Cookie -> Bool
cookieSecure Cookie
c then forall a. a -> Maybe a
Just String
"secure" else forall a. Maybe a
Nothing
          httpOnly :: Maybe String
httpOnly = if Cookie -> Bool
cookieHttpOnly Cookie
c then forall a. a -> Maybe a
Just String
"HttpOnly" else forall a. Maybe a
Nothing
          dateFmt :: UTCTime -> String
dateFmt = forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
rfc822DateFormat

-- | 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 :: String -> ShowS
showPair String
name String
value = String
name forall a. [a] -> [a] -> [a]
++ String
"=" forall a. [a] -> [a] -> [a]
++ String
value


-- | Gets all the cookies from a Cookie: header value
readCookies :: String             -- ^ String to parse
            -> [(String,String)]  -- ^ Cookie name - cookie value pairs
readCookies :: String -> [(String, String)]
readCookies String
s =
    let (String
xs,String
ys) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
==Char
'=') (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
s)
        (String
zs,String
ws) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
==Char
';') (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (forall a. Int -> [a] -> [a]
drop Int
1 String
ys))
     in if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
xs then [] else (String
xs,String
zs)forall a. a -> [a] -> [a]
:String -> [(String, String)]
readCookies (forall a. Int -> [a] -> [a]
drop Int
1 String
ws)

--
-- Utilities
--

-- | Return 'Nothing' is the list is empty, otherwise return
--   the last element of the list.
maybeLast :: [a] -> Maybe a
maybeLast :: forall a. [a] -> Maybe a
maybeLast [] = forall a. Maybe a
Nothing
maybeLast [a]
xs = forall a. a -> Maybe a
Just (forall a. [a] -> a
last [a]
xs)