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)
data Cookie = Cookie {
Cookie -> String
cookieName :: String,
Cookie -> String
cookieValue :: String,
Cookie -> Maybe UTCTime
cookieExpires :: Maybe UTCTime,
Cookie -> Maybe String
cookieDomain :: Maybe String,
Cookie -> Maybe String
cookiePath :: Maybe String,
Cookie -> Bool
cookieSecure :: Bool,
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)
newCookie :: String
-> String
-> 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
}
findCookie :: String
-> String
-> Maybe String
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 ]
deleteCookie :: Cookie
-> 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
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
showPair :: String
-> String
-> 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
readCookies :: String
-> [(String,String)]
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)
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)