diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,9 @@ +# Revision history for web-cookiejar + +`web-cookiejar` uses [PVP Versioning][1]. + +## 0.1.0.0 -- 2025-04-07 + +* Initial version. + +[1]: https://pvp.haskell.org diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2023, Tim Emiola + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Tim Emiola nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple + + +main = defaultMain diff --git a/src/Web/Cookie/Jar.hs b/src/Web/Cookie/Jar.hs new file mode 100644 --- /dev/null +++ b/src/Web/Cookie/Jar.hs @@ -0,0 +1,223 @@ +{-# 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 = parseOnly cookieJarParser + + +-- | @Parser@ for a cookie jar in the Netscape/Mozilla format +cookieJarParser :: Parser CookieJar +cookieJarParser = createCookieJar <$> many' 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 = + let + httpOnlyLine = try $ "#HttpOnly_" *> cookieParser' True + commentLine = "#" *> skipWhile notEndOfLine *> endOfLine *> cookieParser + cookieLine = cookieParser' False + in + skipSpace *> (httpOnlyLine <|> commentLine <|> cookieLine) + + +-- | Basic parser for a line containing a cookie in the Netscape/Mozilla format +cookieParser' :: Bool -> Parser Cookie +cookieParser' cookie_http_only = do + let + epoch = posixSecondsToUTCTime 0 + -- component parsers + tab = void $ char '\t' + parseString = takeWhile1 (/= '\t') + parseBool = True <$ "TRUE" <|> False <$ "FALSE" + parseTime = posixSecondsToUTCTime . fromInteger <$> decimal + parseValue = takeWhile1 notEndOfLine + cookie_domain <- parseString + tab + cookie_host_only <- parseBool + tab + cookie_path <- parseString + tab + cookie_secure_only <- parseBool + tab + cookie_expiry_time <- parseTime + tab + cookie_name <- parseString + tab + cookie_value <- parseValue + endOfLine <|> pure () + pure $ + Cookie + { cookie_domain + , cookie_path + , cookie_secure_only + , cookie_expiry_time + , cookie_name + , cookie_value + , cookie_host_only + , cookie_http_only + , -- fields not represented by the cookie jar format + cookie_creation_time = epoch + , cookie_last_access_time = epoch + , cookie_persistent = True + } + + +notEndOfLine :: Char -> Bool +notEndOfLine = not . isEndOfLine . fromIntegral . ord + + +-- | Like 'jarBuilder' but outputs the Netscape header before the cookie lines +netscapeJarBuilder :: CookieJar -> Builder +netscapeJarBuilder = jarBuilder' netscapeHeader + + +netscapeHeader :: Builder +netscapeHeader = "# Netscape HTTP Cookie File\n" + + +-- | Print a cookie jar in the Netscape/Mozilla format, with no header +jarBuilder :: CookieJar -> Builder +jarBuilder = foldMap ((<> "\n") . cookieBuilder) . destroyCookieJar + + +-- | Like 'jarBuilder' but outputs a header before the cookie lines +jarBuilder' :: Builder -> CookieJar -> Builder +jarBuilder' header = (header <>) . jarBuilder + + +-- | Writes a cookie jar to the given path in the Netscape/Mozilla format, with no header +writeJar :: FilePath -> CookieJar -> IO () +writeJar fp = L.writeFile fp . toLazyByteString . jarBuilder + + +-- | Like 'writeJar', but outputs a header before the cookie lines +writeJar' :: Builder -> FilePath -> CookieJar -> IO () +writeJar' header fp = + L.writeFile fp + . toLazyByteString + . jarBuilder' + header + + +-- | Like 'writeJar', but outputs the Netscape header before the cookie lines +writeNetscapeJar :: FilePath -> CookieJar -> IO () +writeNetscapeJar = writeJar' netscapeHeader + + +-- | Read a Cookie Jar from a file. +readJar :: FilePath -> IO (Either String CookieJar) +readJar = fmap parseCookieJar . 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 c = + let + httpOnly True = "#HttpOnly_" + httpOnly False = mempty + bool True = "TRUE" + bool False = "FALSE" + unixTime = integerDec . round . utcTimeToPOSIXSeconds + tab = char7 '\t' + in + httpOnly (cookie_http_only c) + <> byteString (cookie_domain c) + <> tab + <> bool (cookie_host_only c) + <> tab + <> byteString (cookie_path c) + <> tab + <> bool (cookie_secure_only c) + <> tab + <> unixTime (cookie_expiry_time c) + <> tab + <> byteString (cookie_name c) + <> tab + <> byteString (cookie_value c) diff --git a/test/Cookie/JarSpec.hs b/test/Cookie/JarSpec.hs new file mode 100644 --- /dev/null +++ b/test/Cookie/JarSpec.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Cookie.JarSpec +Copyright : (c) 2023 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 +-} +module Cookie.JarSpec (spec) where + +import Data.ByteString (ByteString) +import Data.ByteString.Builder (Builder, toLazyByteString) +import qualified Data.ByteString.Lazy as L +import Data.List (sortBy) +import Data.String (fromString) +import Data.Time (UTCTime) +import Data.Time.Clock.POSIX + ( posixSecondsToUTCTime + ) +import Data.Word (Word16) +import Network.HTTP.Client + ( Cookie (..) + , CookieJar + , compareCookies + , createCookieJar + , destroyCookieJar + , equalCookie + ) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec +import Test.QuickCheck + ( Arbitrary (arbitrary) + , Gen + , Property + , chooseInteger + , forAll + , listOf1 + , suchThat + ) +import Test.QuickCheck.Monadic (assert, monadicIO, pick, run) +import Web.Cookie.Jar + + +spec :: Spec +spec = describe "Module Web.Cookie.Jar" $ do + context "parsing with cookieParser" $ do + context "and building with cookieBuilder" $ do + it "should almost roundtrip" prop_almostRoundtripCookie + + context "parsing with cookieJarParser" $ do + context "and building with jarBuilder" $ do + it "should almost roundtrip" (prop_almostRoundtripCookieJar jarBuilder) + + context "and building netscapeJarBuilder" $ do + it "should almost roundtrip" (prop_almostRoundtripCookieJar netscapeJarBuilder) + + context "when accessing persisted jars" $ around useTmp $ do + context "writeJar then readJar" $ do + it "should almost roundtrip" (prop_almostRoundtripSavedJars writeJar) + context "writeNetscapeJar then readJar" $ do + it "should almost roundtrip" (prop_almostRoundtripSavedJars writeNetscapeJar) + + +useTmp :: (FilePath -> IO a) -> IO a +useTmp = withSystemTempDirectory "web-cookiejar" + + +genJarWithPath :: Gen (FilePath, CookieJar) +genJarWithPath = do + let mkPath i = "cookie-jar-" ++ i ++ ".txt" + index <- mkPath . show <$> genWord16 + (,) index <$> genCookieJar + + +prop_almostRoundtripSavedJars :: (FilePath -> CookieJar -> IO ()) -> FilePath -> Property +prop_almostRoundtripSavedJars writer root = monadicIO $ do + (jarBase, jar) <- pick genJarWithPath + let jarPath = root ++ "/" ++ jarBase + + -- this match is incomplete, that's ok, the test fails if it produces a Left + Right jar' <- run $ do + writer jarPath jar + readJar jarPath + assert $ almostEqJar jar jar' + + +prop_almostRoundtripCookieJar :: (CookieJar -> Builder) -> Property +prop_almostRoundtripCookieJar toBuilder = + forAll (cookieJarWithX toBuilder <$> genCookieJar) $ \(j, _txt, j') -> + either (const False) (almostEqJar j) j' + + +cookieJarWithX + :: (CookieJar -> Builder) -> CookieJar -> (CookieJar, ByteString, Either String CookieJar) +cookieJarWithX toBuilder j = + let txt = asByteString $ toBuilder j + in (j, txt, parseCookieJar txt) + + +genCookieJar :: Gen CookieJar +genCookieJar = createCookieJar <$> listOf1 genCookie + + +almostEqJar :: CookieJar -> CookieJar -> Bool +almostEqJar jar1 jar2 = + let + cookiesOf = sortBy compareCookies . map fixup . destroyCookieJar + in + and $ zipWith equalCookie (cookiesOf jar1) (cookiesOf jar2) + + +prop_almostRoundtripCookie :: Property +prop_almostRoundtripCookie = + forAll (cookieWithLine <$> genCookie) $ \(c, line) -> + either (const False) (almostEq c) $ parseOnly cookieParser line + + +asByteString :: Builder -> ByteString +asByteString = L.toStrict . toLazyByteString + + +cookieWithLine :: Cookie -> (Cookie, ByteString) +cookieWithLine c = (c, asByteString $ cookieBuilder c) + + +genCookie :: Gen Cookie +genCookie = do + (creation, expiry) <- genCreationAndExpiry + Cookie + <$> genWithSuffix "name_" + <*> genWithSuffix "value_" + <*> pure expiry + <*> genWithSuffix "domain_" + <*> genWithSuffix "path_" + <*> pure creation + <*> pure creation + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + + +genCreationAndExpiry :: Gen (UTCTime, UTCTime) +genCreationAndExpiry = do + creation <- genUTCTime + expiry <- genUTCTime `suchThat` (> creation) + pure (creation, expiry) + + +almostEq :: Cookie -> Cookie -> Bool +almostEq c1 c2 = fixup c1 `equalCookie` fixup c2 + + +fixup :: Cookie -> Cookie +fixup c = + let epoch = posixSecondsToUTCTime 0 + in c + { cookie_persistent = True + , cookie_last_access_time = epoch + , cookie_creation_time = epoch + } + + +genWord16 :: Gen Word16 +genWord16 = arbitrary + + +genUTCTime :: Gen UTCTime +genUTCTime = posixSecondsToUTCTime . fromInteger <$> chooseInteger (1, 365 * 86400 * 20) + + +genWithSuffix :: ByteString -> Gen ByteString +genWithSuffix bs = (bs <>) . fromString . show <$> genWord16 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import qualified Cookie.JarSpec as Jar +import System.IO ( + BufferMode (..), + hSetBuffering, + stderr, + stdout, + ) +import Test.Hspec + + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + hSetBuffering stderr NoBuffering + hspec $ do + Jar.spec diff --git a/web-cookiejar.cabal b/web-cookiejar.cabal new file mode 100644 --- /dev/null +++ b/web-cookiejar.cabal @@ -0,0 +1,59 @@ +cabal-version: 3.0 +name: web-cookiejar +version: 0.1.0.0 +synopsis: Parsing/printing of persistent web cookies +description: + A library that provides parsing and printing functions that read and write web + cookies stored in the Netscape/Mozilla cookie jar file format; also the format + used by curl. + + See the [README](https://github.com/adetokunbo/web-cookiejar?tab=readme-ov-file#web-cookiejar) + for a simple usage example + +license: BSD-3-Clause +license-file: LICENSE +author: Tim Emiola +maintainer: adetokunbo@emio.la +category: Web +homepage: https://github.com/adetokunbo/web-cookiejar#readme +bug-reports: + https://github.com/adetokunbo/web-cookiejar/issues +tested-with: GHC ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.2 || ==9.10.1 +build-type: Simple +extra-source-files: + ChangeLog.md + +source-repository head + type: git + location: https://github.com/adetokunbo/web-cookiejar.git + +library + exposed-modules: Web.Cookie.Jar + hs-source-dirs: src + build-depends: + , attoparsec >=0.14.4 && <0.15 + , base >=4.10 && <5 + , bytestring >=0.10.8 && <0.11 || >=0.11.3 && <0.13 + , http-client >=0.5 && <0.8 + , time >=1.8 && <1.15 + + default-language: Haskell2010 + ghc-options: -Wall -Wincomplete-uni-patterns -Wpartial-fields -fwarn-tabs + +test-suite test + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + other-modules: Cookie.JarSpec + default-language: Haskell2010 + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fwarn-tabs + build-depends: + , base + , bytestring + , hspec >=2.7.0 && <2.12.0 + , http-client + , QuickCheck >= 2.13 && < 2.16 + , temporary >= 1.2 && < 1.4 + , time + , web-cookiejar +