    -----------------------------------------------------------------------------
    -- |
    -- 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
    (Int -> Cookie -> ShowS)
    -> (Cookie -> String) -> ([Cookie] -> ShowS) -> Show Cookie
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> Cookie -> ShowS
    showsPrec :: Int -> Cookie -> ShowS
    $cshow :: Cookie -> String
    show :: Cookie -> String
    $cshowList :: [Cookie] -> ShowS
    showList :: [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
    $creadsPrec :: Int -> ReadS Cookie
    readsPrec :: Int -> ReadS Cookie
    $creadList :: ReadS [Cookie]
    readList :: ReadS [Cookie]
    $creadPrec :: ReadPrec Cookie
    readPrec :: ReadPrec Cookie
    $creadListPrec :: ReadPrec [Cookie]
    readListPrec :: ReadPrec [Cookie]
    Read, Cookie -> Cookie -> Bool
    (Cookie -> Cookie -> Bool)
    -> (Cookie -> Cookie -> Bool) -> Eq Cookie
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: Cookie -> Cookie -> Bool
    == :: Cookie -> Cookie -> Bool
    $c/= :: Cookie -> Cookie -> Bool
    /= :: Cookie -> Cookie -> Bool
    Eq, Eq Cookie
    Eq Cookie =>
    (Cookie -> Cookie -> Ordering)
    -> (Cookie -> Cookie -> Bool)
    -> (Cookie -> Cookie -> Bool)
    -> (Cookie -> Cookie -> Bool)
    -> (Cookie -> Cookie -> Bool)
    -> (Cookie -> Cookie -> Cookie)
    -> (Cookie -> Cookie -> Cookie)
    -> Ord 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
    $ccompare :: Cookie -> Cookie -> Ordering
    compare :: Cookie -> Cookie -> Ordering
    $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
    >= :: Cookie -> Cookie -> Bool
    $cmax :: Cookie -> Cookie -> Cookie
    max :: Cookie -> Cookie -> Cookie
    $cmin :: Cookie -> Cookie -> Cookie
    min :: Cookie -> Cookie -> Cookie
    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 = Maybe UTCTime
    forall a. Maybe a
    Nothing,
                                    cookieDomain :: Maybe String
    cookieDomain = Maybe String
    forall a. Maybe a
    Nothing,
                                    cookiePath :: Maybe String
    cookiePath = Maybe String
    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 = [String] -> Maybe String
    forall a. [a] -> Maybe a
    maybeLast [ String
    cv | (String
    cn,String
    cv) <- String -> [(String, String)]
    readCookies String
    s, String
    cn String -> String -> Bool
    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 = Just 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 = String -> [String] -> String
    forall a. [a] -> [[a]] -> [a]
    intercalate String
    "; " ([String] -> String) -> [String] -> String
    forall a b. (a -> b) -> a -> b
    $
                    String -> ShowS
    showPair (Cookie -> String
    cookieName Cookie
    c) (Cookie -> String
    cookieValue Cookie
    c)
                     String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    : [Maybe String] -> [String]
    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 = (UTCTime -> String) -> Maybe UTCTime -> Maybe String
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (String -> ShowS
    showPair String
    "expires" ShowS -> (UTCTime -> String) -> UTCTime -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . UTCTime -> String
    dateFmt) (Cookie -> Maybe UTCTime
    cookieExpires Cookie
    c)
              domain :: Maybe String
    domain = ShowS -> Maybe String -> Maybe String
    forall a b. (a -> b) -> Maybe a -> Maybe b
    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 = ShowS -> Maybe String -> Maybe String
    forall a b. (a -> b) -> Maybe a -> Maybe b
    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 String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "secure" else Maybe String
    forall a. Maybe a
    Nothing
              httpOnly :: Maybe String
    httpOnly = if Cookie -> Bool
    cookieHttpOnly Cookie
    c then String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "HttpOnly" else Maybe String
    forall a. Maybe a
    Nothing
              dateFmt :: UTCTime -> String
    dateFmt = TimeLocale -> String -> UTCTime -> String
    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 String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "=" String -> ShowS
    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) = (Char -> Bool) -> String -> (String, String)
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    break (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    ==Char
    '=') ((Char -> Bool) -> ShowS
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isSpace String
    s)
            (String
    zs,String
    ws) = (Char -> Bool) -> String -> (String, String)
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    break (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    ==Char
    ';') ((Char -> Bool) -> ShowS
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isSpace (Int -> ShowS
    forall a. Int -> [a] -> [a]
    drop Int
    1 String
    ys))
         in if String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null String
    xs then [] else (String
    xs,String
    zs)(String, String) -> [(String, String)] -> [(String, String)]
    forall a. a -> [a] -> [a]
    :String -> [(String, String)]
    readCookies (Int -> ShowS
    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 [] = Maybe a
    forall a. Maybe a
    Nothing
    maybeLast [a]
    xs = a -> Maybe a
    forall a. a -> Maybe a
    Just ([a] -> a
    forall a. HasCallStack => [a] -> a
    last [a]
    xs)