cookie-tray (empty) → 0.0.0.0

raw patch · 12 files changed

+609/−0 lines, 12 filesdep +basedep +binarydep +bytestring

Dependencies added: base, binary, bytestring, containers, cookie, cookie-tray, hspec, time

Files

• changelog.md +1/−0
• cookie-tray.cabal +64/−0
• library/CookieTray.hs +224/−0
• library/CookieTray/Command.hs +17/−0
• library/CookieTray/Command/Many.hs +29/−0
• library/CookieTray/Command/PutMany.hs +29/−0
• library/CookieTray/Command/PutOne.hs +29/−0
• library/CookieTray/Time.hs +10/−0
• library/CookieTray/Types.hs +95/−0
• license.txt +13/−0
• readme.md +41/−0
• test/Main.hs +57/−0

@@ -0,0 +1,1 @@+0.0.0.0 - 2023-06-22 - Initial release

@@ -0,0 +1,64 @@+cabal-version: 3.0++name: cookie-tray+version: 0.0.0.0++synopsis: For serving cookies+category: Web++description:+    This package aims to make it easy to set cookies from+    your web server, even if you are not intimately familiar+    with the details of the Set-Cookie HTTP field.++homepage: https://github.com/typeclasses/cookie-tray++extra-source-files: *.md++license: Apache-2.0+license-file: license.txt++author: Chris Martin+maintainer: Chris Martin, Julie Moronuki++common base+    default-language: GHC2021+    ghc-options: -Wall+    default-extensions:+        BlockArguments+        DerivingStrategies+        LambdaCase+        NoImplicitPrelude+        TypeFamilies+    build-depends:+      , base ^>= 4.16 || ^>= 4.17 || ^>= 4.18+      , binary ^>= 0.8.9+      , bytestring ^>= 0.11.4+      , containers ^>= 0.6.5+      , cookie ^>= 0.4.6+      , time ^>= 1.11.1 || ^>= 1.12++library+    import: base+    hs-source-dirs: library+    exposed-modules:+        CookieTray+        CookieTray.Command+        CookieTray.Command.Many+        CookieTray.Command.PutMany+        CookieTray.Command.PutOne+        CookieTray.Time+    other-modules:+        CookieTray.Types++test-suite test-cookie-tray+    import: base+    type: exitcode-stdio-1.0+    default-extensions:+        OverloadedLists+        OverloadedStrings+    hs-source-dirs: test+    main-is: Main.hs+    build-depends:+      , cookie-tray+      , hspec ^>= 2.9.7 || ^>= 2.10 || ^>= 2.11

@@ -0,0 +1,224 @@+module CookieTray+  ( -- * Command+    render,+    renderLBS,+    ToCommandList (..),+    Command,+    Action (..),+    renderCommand,+    BinaryCommand,+    binaryCommandByteStringLazy,++    -- * Tray+    Tray (..),+    parse,+    lookup,+    fromList,+    toList,++    -- * Name+    Name (..),+    Named (..),++    -- * Value+    Value (..),++    -- * Expiry+    Expiry (..),+    Expiring (..),++    -- * Meta++    -- ** Security+    Security (..),+    Secured (..),+    Origin (..),+    TransportEncryption (..),+    SameSiteOptions (..),+    SameSiteStrictness (..),+    JavascriptAccess (..),++    -- ** Scope+    Scope (..),+    Domain (..),+    Path (..),+    Meta (..),+  )+where++import CookieTray.Command (Command, ToCommandList (..))+import CookieTray.Command qualified as Command+import CookieTray.Types+import Data.Binary.Builder qualified as Binary+import Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as BS.Char8+import Data.ByteString.Lazy qualified as LBS+import Data.Functor (Functor, fmap, (<&>))+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Monoid (Endo (..), Monoid (mempty))+import Data.Semigroup (Semigroup ((<>)))+import Data.Time.Clock.POSIX qualified as Time+import GHC.Exts (IsList, Item)+import GHC.Exts qualified as IsList (IsList (..))+import Web.Cookie qualified as Web+import Prelude (Bool (..), Eq, Maybe (..), Ord, Show, ($), (.))++---  Tray  ---++newtype Tray a = Tray (Map Name a)+  deriving (Eq, Ord, Show, Functor)++-- | Left-biased map union+instance Semigroup (Tray a) where+  Tray x <> Tray y = Tray (x <> y)++instance Monoid (Tray a) where+  mempty = Tray mempty++instance IsList (Tray a) where+  type Item (Tray a) = Named a+  fromList = fromList+  toList = toList++parse :: BS.ByteString -> Tray Value+parse =+  fromList+    . fmap (\(a, b) -> Named {name = Name a, value = Value b})+    . Web.parseCookies++toList :: Tray a -> [Named a]+toList (Tray m) =+  Map.toList m <&> \(a, b) ->+    Named {name = a, value = b}++fromList :: [Named a] -> Tray a+fromList = Tray . Map.fromList . fmap (\x -> (name x, value x))++lookup :: Name -> Tray a -> Maybe a+lookup x (Tray m) = Map.lookup x m++---  Command  ---++renderCommand :: Command -> BinaryCommand+renderCommand = renderSetCookie . applyToSetCookie++render :: (ToCommandList a) => a -> [BinaryCommand]+render = fmap renderCommand . toCommandList++renderLBS :: (ToCommandList a) => a -> [LBS.ByteString]+renderLBS = fmap binaryCommandByteStringLazy . render++---  Rendering internals  ---++renderSetCookie :: Endo Web.SetCookie -> BinaryCommand+renderSetCookie f =+  BinaryCommand $ Binary.toLazyByteString $ Web.renderSetCookie $ appEndo f Web.def++class ApplyToSetCookie a where+  applyToSetCookie :: a -> Endo Web.SetCookie++instance ApplyToSetCookie Command where+  applyToSetCookie x =+    applyToSetCookie (Command.name x)+      <> applyToSetCookie (Command.meta x)+      <> applyToSetCookie (Command.action x)++instance (ApplyToSetCookie a) => ApplyToSetCookie (Named a) where+  applyToSetCookie x =+    applyToSetCookie (name x)+      <> applyToSetCookie (value x)++instance ApplyToSetCookie Name where+  applyToSetCookie x = Endo \sc -> sc {Web.setCookieName = nameByteString x}++instance ApplyToSetCookie Value where+  applyToSetCookie x = Endo \sc -> sc {Web.setCookieValue = valueByteString x}++instance ApplyToSetCookie TransportEncryption where+  applyToSetCookie x = Endo \sc -> sc {Web.setCookieSecure = y}+    where+      y = case x of+        RequireEncryptedTransport -> True+        AllowUnencryptedTransport -> False++instance ApplyToSetCookie Security where+  applyToSetCookie x =+    applyToSetCookie (jsAccess x)+      <> applyToSetCookie (origin x)++instance ApplyToSetCookie Origin where+  applyToSetCookie = \case+    SameSite o -> applyToSetCookie o+    CrossSite -> Endo \sc ->+      sc+        { Web.setCookieSameSite = Just Web.sameSiteNone,+          Web.setCookieSecure = True -- When SameSite=None, Secure is required+        }++instance ApplyToSetCookie SameSiteOptions where+  applyToSetCookie x =+    applyToSetCookie (sameSiteStrictness x)+      <> applyToSetCookie (transportEncryption x)++instance ApplyToSetCookie SameSiteStrictness where+  applyToSetCookie x = Endo \sc ->+    sc+      { Web.setCookieSameSite = Just+          case x of+            SameSiteStrict -> Web.sameSiteStrict+            SameSiteLax -> Web.sameSiteLax+      }++instance ApplyToSetCookie JavascriptAccess where+  applyToSetCookie x = Endo \sc -> sc {Web.setCookieHttpOnly = y}+    where+      y = case x of+        HiddenFromJavascript -> True+        AccessibleFromJavascript -> False++instance ApplyToSetCookie Domain where+  applyToSetCookie x = Endo \sc -> sc {Web.setCookieDomain = y}+    where+      y = case x of+        Domain z -> Just z+        CurrentHostExcludingSubdomains -> Nothing++instance ApplyToSetCookie Expiry where+  applyToSetCookie = \case+    ExpiryTime x -> Endo \sc -> sc {Web.setCookieExpires = Just x}+    ExpiryAge x -> Endo \sc -> sc {Web.setCookieMaxAge = Just x}++instance ApplyToSetCookie Path where+  applyToSetCookie x = Endo \sc -> sc {Web.setCookiePath = y}+    where+      y = case x of+        Path z -> Just z+        CurrentPath -> Nothing++instance ApplyToSetCookie Scope where+  applyToSetCookie x =+    applyToSetCookie (domain x)+      <> applyToSetCookie (path x)++instance ApplyToSetCookie Meta where+  applyToSetCookie x =+    applyToSetCookie (metaScope x)+      <> applyToSetCookie (metaSecurity x)++instance (ApplyToSetCookie a) => ApplyToSetCookie (Secured a) where+  applyToSetCookie x =+    applyToSetCookie (security x)+      <> applyToSetCookie (secured x)++instance (ApplyToSetCookie a) => ApplyToSetCookie (Action a) where+  applyToSetCookie = \case+    Put x -> applyToSetCookie x+    Delete ->+      applyToSetCookie (ExpiryTime (Time.posixSecondsToUTCTime 0))+        <> applyToSetCookie (Value (BS.Char8.pack "x"))++instance (ApplyToSetCookie a) => ApplyToSetCookie (Expiring a) where+  applyToSetCookie x =+    applyToSetCookie (expiry x)+      <> applyToSetCookie (expiring x)

@@ -0,0 +1,17 @@+module CookieTray.Command where++import CookieTray.Types+import Prelude (Eq, Ord, Show)++data Command = Command+  { name :: Name,+    meta :: Meta,+    action :: Action (Expiring Value)+  }+  deriving (Eq, Ord, Show)++class ToCommandList a where+  toCommandList :: a -> [Command]++instance ToCommandList Command where+  toCommandList = (: [])

@@ -0,0 +1,29 @@+module CookieTray.Command.Many where++import CookieTray (Action (..), Expiring (Expiring), Expiry, Meta (..), Named (..), ToCommandList (..), Tray, Value)+import CookieTray qualified+import CookieTray.Command (Command (Command))+import CookieTray.Command qualified as Command+import Data.Functor ((<&>))+import Prelude (Eq, Ord, Show)++data Many = Many+  { tray :: Tray (Action Value),+    expiry :: Expiry,+    meta :: Meta+  }+  deriving (Eq, Ord, Show)++instance ToCommandList Many where+  toCommandList x =+    CookieTray.toList (tray x) <&> \y ->+      Command+        { Command.name = CookieTray.name y,+          Command.meta = meta x,+          Command.action =+            value y <&> \z ->+              Expiring+                { CookieTray.expiring = z,+                  CookieTray.expiry = expiry x+                }+        }

@@ -0,0 +1,29 @@+module CookieTray.Command.PutMany where++import CookieTray (Action (..), Expiring (Expiring), Expiry, Meta (..), ToCommandList (..), Tray, Value)+import CookieTray qualified+import CookieTray.Command (Command (Command))+import CookieTray.Command qualified as Command+import Data.Functor ((<&>))+import Prelude (Eq, Ord, Show)++data PutMany = PutMany+  { tray :: Tray Value,+    expiry :: Expiry,+    meta :: Meta+  }+  deriving (Eq, Ord, Show)++instance ToCommandList PutMany where+  toCommandList x =+    CookieTray.toList (tray x) <&> \y ->+      Command+        { Command.name = CookieTray.name y,+          Command.meta = meta x,+          Command.action =+            Put+              Expiring+                { CookieTray.expiring = CookieTray.value y,+                  CookieTray.expiry = expiry x+                }+        }

@@ -0,0 +1,29 @@+module CookieTray.Command.PutOne where++import CookieTray (Action (..), Expiring (Expiring), Expiry, Meta (..), Name, ToCommandList (..), Value)+import CookieTray qualified+import CookieTray.Command (Command (Command))+import CookieTray.Command qualified as Command+import Prelude (Eq, Ord, Show)++data PutOne = PutOne+  { name :: Name,+    value :: Value,+    expiry :: Expiry,+    meta :: Meta+  }+  deriving (Eq, Ord, Show)++instance ToCommandList PutOne where+  toCommandList x =+    (: [])+      Command+        { Command.name = name x,+          Command.meta = meta x,+          Command.action =+            Put+              Expiring+                { CookieTray.expiring = value x,+                  CookieTray.expiry = expiry x+                }+        }

@@ -0,0 +1,10 @@+module CookieTray.Time where++import Data.Time qualified as Time+import Prelude (($), (*), round)++-- | Roughly the length of a year+--+-- This can be useful for setting cookie expiration times.+year :: Time.DiffTime+year = Time.secondsToDiffTime $ round $ Time.nominalDiffTimeToSeconds $ Time.nominalDay * 365

@@ -0,0 +1,95 @@+module CookieTray.Types where++import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as LBS+import Data.String (IsString)+import Data.Time (DiffTime, UTCTime)+import Prelude (Eq, Functor, Ord, Show)++newtype Name = Name {nameByteString :: BS.ByteString}+  deriving newtype (Eq, Ord, Show, IsString)++data Named a = Named {name :: Name, value :: a}+  deriving stock (Eq, Ord, Show)++newtype Value = Value {valueByteString :: BS.ByteString}+  deriving newtype (Eq, Ord, Show, IsString)++-- | The raw content of a set-cookie header+newtype BinaryCommand = BinaryCommand {binaryCommandByteStringLazy :: LBS.ByteString}+  deriving newtype (Eq, Ord, Show, IsString)++data JavascriptAccess+  = -- | HttpOnly; javascript cannot access the cookie+    HiddenFromJavascript+  | -- | Cookie will be accessible from javascript,+    -- see https://developer.mozilla.org/en-US/docs/web/api/document/cookie+    AccessibleFromJavascript+  deriving (Eq, Ord, Show)++data TransportEncryption+  = -- | The browser only sends cookies over HTTP, not HTTP+    RequireEncryptedTransport+  | -- | The browser sends cookies regardless of transport encryption+    AllowUnencryptedTransport+  deriving (Eq, Ord, Show)++data Origin+  = SameSite SameSiteOptions+  | -- | Instruct the client to send the cookie for all requests,+    -- even those originating from a third party.+    -- This option implies 'RequireEncryptedTransport'.+    CrossSite+  deriving (Eq, Ord, Show)++data SameSiteOptions = SameSiteOptions+  { sameSiteStrictness :: SameSiteStrictness,+    transportEncryption :: TransportEncryption+  }+  deriving (Eq, Ord, Show)++data SameSiteStrictness+  = -- | Instruct the client not to send the cookie for requests originating+    -- from another site, e.g. if a user clicked a link from another site to+    -- yours. This setting offers the strongest protection against cross-site+    -- request forgery, but does not make sense in a lot of cases. (If somebody+    -- follows a link to your site, should they appear to be logged out?)+    SameSiteStrict+  | -- | The client will send the cookie whenever your domain is what appears+    -- in the navigation bar+    SameSiteLax+  deriving (Eq, Ord, Show)++data Security = Security+  { jsAccess :: JavascriptAccess,+    origin :: Origin+  }+  deriving (Eq, Ord, Show)++data Secured a = Secured+  { security :: Security,+    secured :: a+  }+  deriving (Eq, Ord, Show, Functor)++data Expiry = ExpiryTime UTCTime | ExpiryAge DiffTime+  deriving (Eq, Ord, Show)++data Expiring a = Expiring {expiry :: Expiry, expiring :: a}+  deriving (Eq, Ord, Show, Functor)++-- | The host to which the cookie will be sent+data Domain = Domain BS.ByteString | CurrentHostExcludingSubdomains+  deriving (Eq, Ord, Show)++data Path = Path BS.ByteString | CurrentPath+  deriving (Eq, Ord, Show)++data Scope = Scope {domain :: Domain, path :: Path}+  deriving (Eq, Ord, Show)++data Meta = Meta {metaScope :: Scope, metaSecurity :: Security}+  deriving (Eq, Ord, Show)++data Action a = Delete | Put a+  deriving (Eq, Ord, Show, Functor)

@@ -0,0 +1,13 @@+Copyright 2023 Mission Valley Software LLC++Licensed under the Apache License, Version 2.0 (the "License");+you may not use this file except in compliance with the License.+You may obtain a copy of the License at++    http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.

@@ -0,0 +1,41 @@+The `cookie-tray` package aims to make it easy to set cookies from your web+server, even if you are not intimately familiar with the details of the+`Set-Cookie` HTTP field.++One example of a higher-level abstraction provided by this library is the idea+of cookie deletion. The low-level specification gives no way to explicitly+instruct a client to unset a cookie. This library provides a `Delete` action+that does the right thing (sets the cookie with an expiration date in the past)+to achieve removal.++---++Currently the best way to see how the library is used is to look at the test+suite.++---++I currently consider the API to be "experimental" because I don't think its+chief goals of being convenient and instructive have been satisfied confidently+enough to consider the library "finished." I am open to accepting improvements+to make the library more convenient to use.++---++This package works nicely in conjunction with [wai] and [warp]. See+[mapResponseHeaders] in WAI for how to apply fields to the response header.++I am not sure how one would use this with [scotty], as you may be thwarted by+Scotty's use of `Text` instead of `ByteString` to represent HTTP fields.++  [scotty]: https://hackage.haskell.org/package/scotty+  [mapResponseHeaders]: https://hackage.haskell.org/package/wai-3.2.3/docs/Network-Wai.html#v:mapResponseHeaders+  [wai]: https://hackage.haskell.org/package/wai+  [warp]: https://hackage.haskell.org/package/warp++---++Reference documentation on cookies:++* [MDN Web Docs](https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Set-Cookie)+* [IETF specification](https://datatracker.ietf.org/doc/html/rfc6265)

@@ -0,0 +1,57 @@+module Main (main) where++-- You'll definitely need to import this.+import CookieTray++-- You'll probably need to import only one of these.+import CookieTray.Command.Many (Many (Many))+import CookieTray.Command.PutMany (PutMany (PutMany))+import CookieTray.Command.PutOne (PutOne (PutOne))++import CookieTray.Time (year)+import Data.ByteString.Lazy qualified as LBS+import Data.Time qualified as Time+import Test.Hspec (hspec, shouldBe, specify)+import Prelude++main :: IO ()+main = hspec do+  -- The simplest case is using 'PutOne' to set a single cookie.+  specify "put one" do+    shouldBe @[LBS.ByteString]+      (renderLBS $ PutOne "userId" "917" (ExpiryAge year) (Meta scope1 security1))+      ["userId=917; Max-Age=31536000; Domain=.example.com; SameSite=Lax"]++  -- If you need to set multiple cookies, it might be slightly more+  -- convenient to assemble the data into a 'Tray' and render the+  -- entire tray at once using 'PutMany'.+  specify "put many" do+    shouldBe @[LBS.ByteString]+      (renderLBS $ PutMany [Named "a" "1", Named "b" "2"] (ExpiryTime time1) (Meta scope1 security2))+      [ "a=1; Expires=Sat, 01-Jan-2050 00:00:00 GMT; Domain=.example.com; Secure; SameSite=Strict",+        "b=2; Expires=Sat, 01-Jan-2050 00:00:00 GMT; Domain=.example.com; Secure; SameSite=Strict"+      ]++  -- The most general utility is 'Many', which can handle a 'Tray' of+  -- actions, where each action is either 'Put' or 'Delete'.+  specify "put and delete" do+    shouldBe @[LBS.ByteString]+      (renderLBS $ Many [Named "a" Delete, Named "b" (Put "xyz")] (ExpiryAge year) (Meta scope2 security1))+      [ "a=x; Path=/docs; Expires=Thu, 01-Jan-1970 00:00:00 GMT; SameSite=Lax",+        "b=xyz; Path=/docs; Max-Age=31536000; SameSite=Lax"+      ]++scope1 :: Scope+scope1 = Scope (Domain ".example.com") CurrentPath++scope2 :: Scope+scope2 = Scope CurrentHostExcludingSubdomains (Path "/docs")++security1 :: Security+security1 = Security AccessibleFromJavascript (SameSite (SameSiteOptions SameSiteLax AllowUnencryptedTransport))++security2 :: Security+security2 = Security AccessibleFromJavascript (SameSite (SameSiteOptions SameSiteStrict RequireEncryptedTransport))++time1 :: Time.UTCTime+time1 = Time.UTCTime (Time.fromGregorian 2050 1 1) 0