module Network.Protocol.Cookie
(
Cookie (Cookie)
, empty
, cookie
, setCookie
, name
, value
, comment
, commentURL
, discard
, domain
, maxAge
, expires
, path
, port
, secure
, version
, Cookies
, unCookies
, cookies
, setCookies
, pickCookie
, fromList
, toList
)
where
import Prelude hiding ((.), id)
import Control.Category
import Control.Monad (join)
import Data.Record.Label
import Data.Maybe
import Data.Char
import Safe
import Data.List
import Network.Protocol.Uri.Query
import qualified Data.Map as M
data Cookie =
Cookie
{ _name :: String
, _value :: String
, _comment :: Maybe String
, _commentURL :: Maybe String
, _discard :: Bool
, _domain :: Maybe String
, _maxAge :: Maybe Int
, _expires :: Maybe String
, _path :: Maybe String
, _port :: [Int]
, _secure :: Bool
, _version :: Int
} deriving Eq
$(mkLabels [''Cookie])
name :: Cookie :-> String
value :: Cookie :-> String
comment :: Cookie :-> Maybe String
commentURL :: Cookie :-> Maybe String
discard :: Cookie :-> Bool
domain :: Cookie :-> Maybe String
maxAge :: Cookie :-> Maybe Int
expires :: Cookie :-> Maybe String
path :: Cookie :-> Maybe String
port :: Cookie :-> [Int]
secure :: Cookie :-> Bool
version :: Cookie :-> Int
empty :: Cookie
empty = Cookie "" "" Nothing Nothing False Nothing Nothing Nothing Nothing [] False 0
instance Show Cookie where
showsPrec _ = showsSetCookie
showsSetCookie :: Cookie -> ShowS
showsSetCookie c =
pair (get name c) (get value c)
. opt "comment" (get comment c)
. opt "commentURL" (get commentURL c)
. bool "discard" (get discard c)
. opt "domain" (get domain c)
. opt "maxAge" (fmap show $ get maxAge c)
. opt "expires" (get expires c)
. opt "path" (get path c)
. lst "port" (map show $ get port c)
. bool "secure" (get secure c)
. opt "version" (optval $ get version c)
where
attr a = showString a
val v = showString ("=" ++ v)
end = showString "; "
single a = attr a . end
pair a v = attr a . val v . end
opt a = maybe id (pair a)
lst _ [] = id
lst a xs = pair a $ intercalate "," xs
bool _ False = id
bool a True = single a
optval 0 = Nothing
optval i = Just (show i)
showCookie :: Cookie -> String
showCookie c = _name c ++ "=" ++ _value c
parseSetCookie :: String -> Cookie
parseSetCookie s =
let p = fw (keyValues ";" "=") s
in Cookie
{ _name = (fromMaybe "" . fmap fst . headMay) p
, _value = (fromMaybe "" . join . fmap snd . headMay) p
, _comment = ( join . lookup "comment") p
, _commentURL = ( join . lookup "commentURL") p
, _discard = (maybe False (const True) . join . lookup "discard") p
, _domain = ( join . lookup "commentURL") p
, _maxAge = (join . fmap readMay . join . lookup "commentURL") p
, _expires = ( join . lookup "expires") p
, _path = ( join . lookup "path") p
, _port = (maybe [] (readDef [1]) . join . lookup "port") p
, _secure = (maybe False (const True) . join . lookup "secure") p
, _version = (maybe 1 (readDef 1) . join . lookup "version") p
}
parseCookie :: String -> Cookie
parseCookie s =
let p = fw (values "=") s
in empty
{ _name = atDef "" p 0
, _value = atDef "" p 1
}
setCookie :: String :<->: Cookie
setCookie = parseSetCookie <-> show
cookie :: String :<->: Cookie
cookie = parseCookie <-> showCookie
data Cookies = Cookies { _unCookies :: M.Map String Cookie }
deriving Eq
$(mkLabels [''Cookies])
unCookies :: Cookies :-> M.Map String Cookie
instance Show Cookies where
showsPrec _ = showsSetCookies
showsSetCookies :: Cookies -> ShowS
showsSetCookies =
is (showString ", ")
. map (shows . snd)
. M.toList
. get unCookies
where
is _ [] = id
is s (x:xs) = foldl (\a b -> a.s.b) x xs
setCookies :: String :<->: Cookies
setCookies = (fromList <-> toList) . (map parseSetCookie <-> map show) . values ","
cookies :: String :<->: Cookies
cookies = (fromList <-> toList) . (map parseCookie <-> map showCookie) . values ";"
pickCookie :: String -> Cookies :-> Maybe Cookie
pickCookie n = lookupL (map toLower n) . unCookies
where lookupL k = label (M.lookup k) (flip M.alter k . const)
fromList :: [Cookie] -> Cookies
fromList = Cookies . M.fromList . map (\a -> (map toLower $ get name a, a))
toList :: Cookies -> [Cookie]
toList = map snd . M.toList . get unCookies