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
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)
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 = 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
}
findCookie :: String
-> String
-> Maybe String
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 ]
deleteCookie :: Cookie
-> 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
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
showPair :: String
-> String
-> String
showPair :: String -> ShowS
showPair String
name String
value = String
name forall a. [a] -> [a] -> [a]
++ String
"=" forall a. [a] -> [a] -> [a]
++ String
value
readCookies :: String
-> [(String,String)]
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)
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)