{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

{- | 'Parser' for a Netscape/Mozilla cookie jar

Provides parsing functions that parse the Netscape/Mozilla cookie jar file
format, along wiht @'Builder's@ that provide an incomplete roundtrip with the
parser.

The roundtrip is incomplete because some of the fields in @Cookie@ are not saved
in the Netscape/Mozilla cookie jar; see `cookieBuilder`.
-}
module Web.Cookie.Jar
  ( -- * read/write Cookie Jar files
    writeJar
  , writeJar'
  , writeNetscapeJar
  , readJar

    -- * Cookie jar format

    -- ** parsing
  , cookieJarParser
  , cookieParser
  , parseCookieJar

    -- ** printing
  , netscapeJarBuilder
  , jarBuilder
  , jarBuilder'
  , cookieBuilder

    -- * re-exports
  , parseOnly
  )
where

import Control.Applicative ((<|>))
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 B
import Data.ByteString.Builder
  ( Builder
  , byteString
  , char7
  , integerDec
  , toLazyByteString
  )
import qualified Data.ByteString.Lazy as L
import Data.Char (ord)
import Data.Time.Clock.POSIX
  ( posixSecondsToUTCTime
  , utcTimeToPOSIXSeconds
  )
import Network.HTTP.Client
  ( Cookie (..)
  , CookieJar
  , createCookieJar
  , destroyCookieJar
  )


-- | Parse a @ByteString@ containing a cookie jar in the Netscape/Mozilla format
parseCookieJar :: ByteString -> Either String CookieJar
parseCookieJar :: ByteString -> Either String CookieJar
parseCookieJar = Parser CookieJar -> ByteString -> Either String CookieJar
forall a. Parser a -> ByteString -> Either String a
parseOnly Parser CookieJar
cookieJarParser


-- | @Parser@ for a cookie jar in the Netscape/Mozilla format
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


{- | Parser for one cookie/line in a cookie jar in the Netscape/Mozilla format
This will also consume any comment lines preceding the cookie line.

This parser recognizes the magic prefix @#HttpOnly_# and sets the appropriate
field in the @Cookie@ datatype
-}
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)


-- | Basic parser for a line containing a cookie in the Netscape/Mozilla format
cookieParser' :: Bool -> Parser Cookie
cookieParser' :: Bool -> Parser ByteString Cookie
cookieParser' Bool
cookie_http_only = do
  let
    epoch :: UTCTime
epoch = POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
0
    -- component parsers
    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
      , -- fields not represented by the cookie jar format
        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


-- | Like 'jarBuilder' but outputs the Netscape header before the cookie lines
netscapeJarBuilder :: CookieJar -> Builder
netscapeJarBuilder :: CookieJar -> Builder
netscapeJarBuilder = Builder -> CookieJar -> Builder
jarBuilder' Builder
netscapeHeader


netscapeHeader :: Builder
netscapeHeader :: Builder
netscapeHeader = Builder
"# Netscape HTTP Cookie File\n"


-- | Print a cookie jar in the Netscape/Mozilla format, with no header
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


-- | Like 'jarBuilder' but outputs a header before the cookie lines
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


-- | Writes a cookie jar to the given path in the Netscape/Mozilla format, with no header
writeJar :: FilePath -> CookieJar -> IO ()
writeJar :: String -> CookieJar -> IO ()
writeJar String
fp = String -> ByteString -> IO ()
L.writeFile String
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


-- | Like 'writeJar', but outputs a header before the cookie lines
writeJar' :: Builder -> FilePath -> CookieJar -> IO ()
writeJar' :: Builder -> String -> CookieJar -> IO ()
writeJar' Builder
header String
fp =
  String -> ByteString -> IO ()
L.writeFile String
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


-- | Like 'writeJar', but outputs the Netscape header before the cookie lines
writeNetscapeJar :: FilePath -> CookieJar -> IO ()
writeNetscapeJar :: String -> CookieJar -> IO ()
writeNetscapeJar = Builder -> String -> CookieJar -> IO ()
writeJar' Builder
netscapeHeader


-- | Read a Cookie Jar from a file.
readJar :: FilePath -> IO (Either String CookieJar)
readJar :: String -> IO (Either String CookieJar)
readJar = (ByteString -> Either String CookieJar)
-> IO ByteString -> IO (Either String 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 String CookieJar
parseCookieJar (IO ByteString -> IO (Either String CookieJar))
-> (String -> IO ByteString)
-> String
-> IO (Either String CookieJar)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ByteString
B.readFile


{- | Builder for one cookie; generates a single line in the Cookie Jar file format

the values of the following fields are not output, as the file format does
support them.

- 'cookie_creation_time'
- 'cookie_last_access_time'
- 'cookie_persistent'
-}
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)