{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Web.Cookie.Jar
(
writeJar
, writeJar'
, writeNetscapeJar
, readJar
, readJarX
, BadJarFile (..)
, addCookiesFromFile
, saveCookies
, usingCookiesFromFile
, usingCookiesFromFile'
, cookieJarParser
, cookieParser
, parseCookieJar
, netscapeJarBuilder
, jarBuilder
, jarBuilder'
, cookieBuilder
, parseOnly
)
where
import Control.Applicative ((<|>))
import Control.Exception (Exception, throwIO)
import Control.Monad (void)
import Data.Attoparsec.ByteString.Char8
( Parser
, char
, decimal
, endOfLine
, isEndOfLine
, many'
, parseOnly
, skipSpace
, skipWhile
, takeWhile1
, try
)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.ByteString.Builder
( Builder
, byteString
, char7
, integerDec
, toLazyByteString
)
import qualified Data.ByteString.Lazy as L
import Data.Char (ord)
import Data.Time (getCurrentTime)
import Data.Time.Clock.POSIX
( posixSecondsToUTCTime
, utcTimeToPOSIXSeconds
)
import Network.HTTP.Client
( Cookie (..)
, CookieJar
, Request
, Response
, createCookieJar
, destroyCookieJar
, insertCookiesIntoRequest
, updateCookieJar
)
import System.Directory (doesFileExist)
usingCookiesFromFile :: FilePath -> Request -> (Request -> IO (Response b)) -> IO (Response b)
usingCookiesFromFile :: forall b.
FilePath
-> Request -> (Request -> IO (Response b)) -> IO (Response b)
usingCookiesFromFile FilePath
jarPath Request
req Request -> IO (Response b)
doReq = do
Request
req' <- FilePath -> Request -> IO Request
addCookiesFromFile FilePath
jarPath Request
req
Response b
resp <- Request -> IO (Response b)
doReq Request
req'
FilePath -> Response b -> Request -> IO (Response b)
forall a. FilePath -> Response a -> Request -> IO (Response a)
saveCookies FilePath
jarPath Response b
resp Request
req'
usingCookiesFromFile' :: FilePath -> (Request -> IO (Response b)) -> Request -> IO (Response b)
usingCookiesFromFile' :: forall b.
FilePath
-> (Request -> IO (Response b)) -> Request -> IO (Response b)
usingCookiesFromFile' FilePath
p = (Request -> (Request -> IO (Response b)) -> IO (Response b))
-> (Request -> IO (Response b)) -> Request -> IO (Response b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (FilePath
-> Request -> (Request -> IO (Response b)) -> IO (Response b)
forall b.
FilePath
-> Request -> (Request -> IO (Response b)) -> IO (Response b)
usingCookiesFromFile FilePath
p)
addCookiesFromFile
:: FilePath
-> Request
-> IO Request
addCookiesFromFile :: FilePath -> Request -> IO Request
addCookiesFromFile FilePath
dataPath Request
req = do
Bool
pathExists <- FilePath -> IO Bool
doesFileExist FilePath
dataPath
if Bool -> Bool
not Bool
pathExists
then Request -> IO Request
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
req
else do
UTCTime
now <- IO UTCTime
getCurrentTime
FilePath -> IO CookieJar
readJarX FilePath
dataPath IO CookieJar -> (CookieJar -> IO Request) -> IO Request
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CookieJar
jar -> do
let (Request
req', CookieJar
_jar') = Request -> CookieJar -> UTCTime -> (Request, CookieJar)
insertCookiesIntoRequest Request
req CookieJar
jar UTCTime
now
Request -> IO Request
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
req'
saveCookies :: FilePath -> Response a -> Request -> IO (Response a)
saveCookies :: forall a. FilePath -> Response a -> Request -> IO (Response a)
saveCookies FilePath
dataPath Response a
resp Request
req = do
Bool
pathExists <- FilePath -> IO Bool
doesFileExist FilePath
dataPath
CookieJar
old <- if Bool
pathExists then FilePath -> IO CookieJar
readJarX FilePath
dataPath else CookieJar -> IO CookieJar
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Cookie] -> CookieJar
createCookieJar [])
UTCTime
now <- IO UTCTime
getCurrentTime
let (CookieJar
updated, Response a
resp_) = Response a
-> Request -> UTCTime -> CookieJar -> (CookieJar, Response a)
forall a.
Response a
-> Request -> UTCTime -> CookieJar -> (CookieJar, Response a)
updateCookieJar Response a
resp Request
req UTCTime
now CookieJar
old
FilePath -> CookieJar -> IO ()
writeJar FilePath
dataPath CookieJar
updated
Response a -> IO (Response a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response a
resp_
data BadJarFile = InvalidJar
deriving (BadJarFile -> BadJarFile -> Bool
(BadJarFile -> BadJarFile -> Bool)
-> (BadJarFile -> BadJarFile -> Bool) -> Eq BadJarFile
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BadJarFile -> BadJarFile -> Bool
== :: BadJarFile -> BadJarFile -> Bool
$c/= :: BadJarFile -> BadJarFile -> Bool
/= :: BadJarFile -> BadJarFile -> Bool
Eq, Int -> BadJarFile -> ShowS
[BadJarFile] -> ShowS
BadJarFile -> FilePath
(Int -> BadJarFile -> ShowS)
-> (BadJarFile -> FilePath)
-> ([BadJarFile] -> ShowS)
-> Show BadJarFile
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BadJarFile -> ShowS
showsPrec :: Int -> BadJarFile -> ShowS
$cshow :: BadJarFile -> FilePath
show :: BadJarFile -> FilePath
$cshowList :: [BadJarFile] -> ShowS
showList :: [BadJarFile] -> ShowS
Show)
instance Exception BadJarFile
parseCookieJar :: ByteString -> Either String CookieJar
parseCookieJar :: ByteString -> Either FilePath CookieJar
parseCookieJar = Parser CookieJar -> ByteString -> Either FilePath CookieJar
forall a. Parser a -> ByteString -> Either FilePath a
parseOnly Parser CookieJar
cookieJarParser
cookieJarParser :: Parser CookieJar
cookieJarParser :: Parser CookieJar
cookieJarParser = [Cookie] -> CookieJar
createCookieJar ([Cookie] -> CookieJar)
-> Parser ByteString [Cookie] -> Parser CookieJar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Cookie -> Parser ByteString [Cookie]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' Parser ByteString Cookie
cookieParser
cookieParser :: Parser Cookie
cookieParser :: Parser ByteString Cookie
cookieParser =
let
httpOnlyLine :: Parser ByteString Cookie
httpOnlyLine = Parser ByteString Cookie -> Parser ByteString Cookie
forall i a. Parser i a -> Parser i a
try (Parser ByteString Cookie -> Parser ByteString Cookie)
-> Parser ByteString Cookie -> Parser ByteString Cookie
forall a b. (a -> b) -> a -> b
$ Parser ByteString ByteString
"#HttpOnly_" Parser ByteString ByteString
-> Parser ByteString Cookie -> Parser ByteString Cookie
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Bool -> Parser ByteString Cookie
cookieParser' Bool
True
commentLine :: Parser ByteString Cookie
commentLine = Parser ByteString ByteString
"#" Parser ByteString ByteString
-> Parser ByteString () -> Parser ByteString ()
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser ByteString ()
skipWhile Char -> Bool
notEndOfLine Parser ByteString ()
-> Parser ByteString () -> Parser ByteString ()
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ()
endOfLine Parser ByteString ()
-> Parser ByteString Cookie -> Parser ByteString Cookie
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString Cookie
cookieParser
cookieLine :: Parser ByteString Cookie
cookieLine = Bool -> Parser ByteString Cookie
cookieParser' Bool
False
in
Parser ByteString ()
skipSpace Parser ByteString ()
-> Parser ByteString Cookie -> Parser ByteString Cookie
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Parser ByteString Cookie
httpOnlyLine Parser ByteString Cookie
-> Parser ByteString Cookie -> Parser ByteString Cookie
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Cookie
commentLine Parser ByteString Cookie
-> Parser ByteString Cookie -> Parser ByteString Cookie
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Cookie
cookieLine)
cookieParser' :: Bool -> Parser Cookie
cookieParser' :: Bool -> Parser ByteString Cookie
cookieParser' Bool
cookie_http_only = do
let
epoch :: UTCTime
epoch = POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
0
tab :: Parser ByteString ()
tab = Parser ByteString Char -> Parser ByteString ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser ByteString Char -> Parser ByteString ())
-> Parser ByteString Char -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$ Char -> Parser ByteString Char
char Char
'\t'
parseString :: Parser ByteString ByteString
parseString = (Char -> Bool) -> Parser ByteString ByteString
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\t')
parseBool :: Parser ByteString Bool
parseBool = Bool
True Bool -> Parser ByteString ByteString -> Parser ByteString Bool
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser ByteString ByteString
"TRUE" Parser ByteString Bool
-> Parser ByteString Bool -> Parser ByteString Bool
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool
False Bool -> Parser ByteString ByteString -> Parser ByteString Bool
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser ByteString ByteString
"FALSE"
parseTime :: Parser ByteString UTCTime
parseTime = POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime)
-> (Integer -> POSIXTime) -> Integer -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> POSIXTime
forall a. Num a => Integer -> a
fromInteger (Integer -> UTCTime)
-> Parser ByteString Integer -> Parser ByteString UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Integer
forall a. Integral a => Parser a
decimal
parseValue :: Parser ByteString ByteString
parseValue = (Char -> Bool) -> Parser ByteString ByteString
takeWhile1 Char -> Bool
notEndOfLine
ByteString
cookie_domain <- Parser ByteString ByteString
parseString
Parser ByteString ()
tab
Bool
cookie_host_only <- Parser ByteString Bool
parseBool
Parser ByteString ()
tab
ByteString
cookie_path <- Parser ByteString ByteString
parseString
Parser ByteString ()
tab
Bool
cookie_secure_only <- Parser ByteString Bool
parseBool
Parser ByteString ()
tab
UTCTime
cookie_expiry_time <- Parser ByteString UTCTime
parseTime
Parser ByteString ()
tab
ByteString
cookie_name <- Parser ByteString ByteString
parseString
Parser ByteString ()
tab
ByteString
cookie_value <- Parser ByteString ByteString
parseValue
Parser ByteString ()
endOfLine Parser ByteString ()
-> Parser ByteString () -> Parser ByteString ()
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> () -> Parser ByteString ()
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Cookie -> Parser ByteString Cookie
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cookie -> Parser ByteString Cookie)
-> Cookie -> Parser ByteString Cookie
forall a b. (a -> b) -> a -> b
$
Cookie
{ ByteString
cookie_domain :: ByteString
cookie_domain :: ByteString
cookie_domain
, ByteString
cookie_path :: ByteString
cookie_path :: ByteString
cookie_path
, Bool
cookie_secure_only :: Bool
cookie_secure_only :: Bool
cookie_secure_only
, UTCTime
cookie_expiry_time :: UTCTime
cookie_expiry_time :: UTCTime
cookie_expiry_time
, ByteString
cookie_name :: ByteString
cookie_name :: ByteString
cookie_name
, ByteString
cookie_value :: ByteString
cookie_value :: ByteString
cookie_value
, Bool
cookie_host_only :: Bool
cookie_host_only :: Bool
cookie_host_only
, Bool
cookie_http_only :: Bool
cookie_http_only :: Bool
cookie_http_only
,
cookie_creation_time :: UTCTime
cookie_creation_time = UTCTime
epoch
, cookie_last_access_time :: UTCTime
cookie_last_access_time = UTCTime
epoch
, cookie_persistent :: Bool
cookie_persistent = Bool
True
}
notEndOfLine :: Char -> Bool
notEndOfLine :: Char -> Bool
notEndOfLine = Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Bool
isEndOfLine (Word8 -> Bool) -> (Char -> Word8) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord
netscapeJarBuilder :: CookieJar -> Builder
netscapeJarBuilder :: CookieJar -> Builder
netscapeJarBuilder = Builder -> CookieJar -> Builder
jarBuilder' Builder
netscapeHeader
netscapeHeader :: Builder
= Builder
"# Netscape HTTP Cookie File\n"
jarBuilder :: CookieJar -> Builder
jarBuilder :: CookieJar -> Builder
jarBuilder = (Cookie -> Builder) -> [Cookie] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n") (Builder -> Builder) -> (Cookie -> Builder) -> Cookie -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cookie -> Builder
cookieBuilder) ([Cookie] -> Builder)
-> (CookieJar -> [Cookie]) -> CookieJar -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CookieJar -> [Cookie]
destroyCookieJar
jarBuilder' :: Builder -> CookieJar -> Builder
jarBuilder' :: Builder -> CookieJar -> Builder
jarBuilder' Builder
header = (Builder
header Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>) (Builder -> Builder)
-> (CookieJar -> Builder) -> CookieJar -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CookieJar -> Builder
jarBuilder
writeJar :: FilePath -> CookieJar -> IO ()
writeJar :: FilePath -> CookieJar -> IO ()
writeJar FilePath
fp = FilePath -> ByteString -> IO ()
L.writeFile FilePath
fp (ByteString -> IO ())
-> (CookieJar -> ByteString) -> CookieJar -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString (Builder -> ByteString)
-> (CookieJar -> Builder) -> CookieJar -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CookieJar -> Builder
jarBuilder
writeJar' :: Builder -> FilePath -> CookieJar -> IO ()
writeJar' :: Builder -> FilePath -> CookieJar -> IO ()
writeJar' Builder
header FilePath
fp =
FilePath -> ByteString -> IO ()
L.writeFile FilePath
fp
(ByteString -> IO ())
-> (CookieJar -> ByteString) -> CookieJar -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString
(Builder -> ByteString)
-> (CookieJar -> Builder) -> CookieJar -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> CookieJar -> Builder
jarBuilder'
Builder
header
writeNetscapeJar :: FilePath -> CookieJar -> IO ()
writeNetscapeJar :: FilePath -> CookieJar -> IO ()
writeNetscapeJar = Builder -> FilePath -> CookieJar -> IO ()
writeJar' Builder
netscapeHeader
readJar :: FilePath -> IO (Either String CookieJar)
readJar :: FilePath -> IO (Either FilePath CookieJar)
readJar = (ByteString -> Either FilePath CookieJar)
-> IO ByteString -> IO (Either FilePath CookieJar)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Either FilePath CookieJar
parseCookieJar (IO ByteString -> IO (Either FilePath CookieJar))
-> (FilePath -> IO ByteString)
-> FilePath
-> IO (Either FilePath CookieJar)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ByteString
BS.readFile
readJarX :: FilePath -> IO CookieJar
readJarX :: FilePath -> IO CookieJar
readJarX FilePath
p =
let handleErr :: Either a a -> IO a
handleErr = (a -> IO a) -> (a -> IO a) -> Either a a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO a -> a -> IO a
forall a b. a -> b -> a
const (IO a -> a -> IO a) -> IO a -> a -> IO a
forall a b. (a -> b) -> a -> b
$ BadJarFile -> IO a
forall e a. Exception e => e -> IO a
throwIO BadJarFile
InvalidJar) a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
in FilePath -> IO (Either FilePath CookieJar)
readJar FilePath
p IO (Either FilePath CookieJar)
-> (Either FilePath CookieJar -> IO CookieJar) -> IO CookieJar
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either FilePath CookieJar -> IO CookieJar
forall {a} {a}. Either a a -> IO a
handleErr
cookieBuilder :: Cookie -> Builder
cookieBuilder :: Cookie -> Builder
cookieBuilder Cookie
c =
let
httpOnly :: Bool -> a
httpOnly Bool
True = a
"#HttpOnly_"
httpOnly Bool
False = a
forall a. Monoid a => a
mempty
bool :: Bool -> a
bool Bool
True = a
"TRUE"
bool Bool
False = a
"FALSE"
unixTime :: UTCTime -> Builder
unixTime = Integer -> Builder
integerDec (Integer -> Builder) -> (UTCTime -> Integer) -> UTCTime -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. POSIXTime -> Integer
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime -> Integer)
-> (UTCTime -> POSIXTime) -> UTCTime -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> POSIXTime
utcTimeToPOSIXSeconds
tab :: Builder
tab = Char -> Builder
char7 Char
'\t'
in
Bool -> Builder
forall {a}. (IsString a, Monoid a) => Bool -> a
httpOnly (Cookie -> Bool
cookie_http_only Cookie
c)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString (Cookie -> ByteString
cookie_domain Cookie
c)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
tab
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Bool -> Builder
forall {a}. IsString a => Bool -> a
bool (Cookie -> Bool
cookie_host_only Cookie
c)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
tab
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString (Cookie -> ByteString
cookie_path Cookie
c)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
tab
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Bool -> Builder
forall {a}. IsString a => Bool -> a
bool (Cookie -> Bool
cookie_secure_only Cookie
c)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
tab
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> UTCTime -> Builder
unixTime (Cookie -> UTCTime
cookie_expiry_time Cookie
c)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
tab
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString (Cookie -> ByteString
cookie_name Cookie
c)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
tab
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString (Cookie -> ByteString
cookie_value Cookie
c)