diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for cookies + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/Cookie.hs b/Cookie.hs new file mode 100644 --- /dev/null +++ b/Cookie.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Cookie + ( Cookie(..) + , CookieContent(..) + , SameSite(..) + , defaultCookie + , encodeCookie + , decodeCookie + ) where + +import Chronos.Types (Datetime, Timespan) +import Data.Bifunctor (second) +import Data.Bool (bool) +import Data.ByteString (ByteString) +import Data.Coerce (coerce) +import Data.Hashable (Hashable) +import Data.Monoid (Monoid) +import Data.Semigroup ((<>)) +import Data.Text (Text) +import Data.Time (UTCTime(UTCTime), formatTime, defaultTimeLocale) +import qualified Chronos as C +import qualified Chronos.Types as C +import qualified Data.List as L +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy.Builder as TL +import qualified Data.Text.Lazy.Builder.Int as TL +import qualified Data.Time as UTC + +data CookieContent a = CookieContent + { cookieContentName :: !Text + , cookieContentValue :: !a + } deriving (Eq, Ord, Show, Functor, Foldable, Traversable) + +data Cookie a = Cookie + { cookieContent :: !(CookieContent a) + , cookieExpires :: !(Maybe Datetime) + , cookieMaxAge :: !(Maybe Timespan) + , cookieDomain :: !(Maybe Text) + , cookiePath :: !(Maybe [Text]) + , cookieSecure :: !Bool + , cookieHttpOnly :: !Bool + , cookieSameSite :: !(Maybe SameSite) + } deriving (Eq, Ord, Show, Functor, Foldable, Traversable) + +data SameSite + = SameSiteLax + | SameSiteStrict + deriving (Eq, Ord, Show) + +defaultCookie :: CookieContent a -> Cookie a +defaultCookie content = Cookie content Nothing Nothing Nothing Nothing False False Nothing + +encodeCookie :: (a -> ByteString) -> Cookie a -> TL.Builder +encodeCookie encodeContent (Cookie (CookieContent name value) expires maxAge domain path secure httpOnly sameSite) = + (mconcat . L.intersperse "; " . mconcat) + [ [ TL.fromText name <> "=" <> (TL.fromText . TE.decodeUtf8 . encodeContent) value ] + , maybeToList expires $ \ex -> "Expires=" <> TL.fromText (formatExpires $ datetimeToUTCTime ex) + , maybeToList maxAge $ \ma -> "Max-Age=" <> TL.decimal (C.getTimespan ma `div` 1000000000) + , maybeToList domain $ \d -> "Domain=" <> TL.fromText d + , maybeToList path $ \p -> "Path=/" <> TL.fromText (T.intercalate "/" p) + , bool [] ["Secure"] secure + , bool [] ["HttpOnly"] httpOnly + , maybeToList sameSite $ \case + SameSiteLax -> "SameSite=Lax" + SameSiteStrict -> "SameSite=Strict" + ] + where + datetimeToUTCTime :: Datetime -> UTCTime + datetimeToUTCTime dt@(C.Datetime _ (C.TimeOfDay h m n)) = UTCTime d undefined + where + dif = UTC.secondsToDiffTime $ fromIntegral (3600 * h + 60 * m + fromIntegral (n `div` 1000000000)) + d = UTC.ModifiedJulianDay $ fromIntegral $ C.getDay $ C.timeToDayTruncate $ C.datetimeToTime dt + formatExpires :: UTCTime -> Text + formatExpires = T.pack . formatTime defaultTimeLocale expiresFormat + expiresFormat = "%a, %d-%b-%Y %X GMT" + maybeToList m f = maybe [] ((:[]) . f) m + +decodeCookie :: (Text -> Either Text a) -> Text -> Either Text (Cookie a) +decodeCookie decodeValue txt = case L.filter (\(x,_) -> x == "auth") (kvPairs txt) of + ((name,value):_) -> + flip fmap (decodeValue value) $ \v -> + Cookie + { cookieContent = CookieContent name v + , cookieExpires = Nothing + , cookieMaxAge = Nothing + , cookieDomain = Nothing + , cookiePath = Nothing + , cookieSecure = False + , cookieHttpOnly = False + , cookieSameSite = Nothing + } + _ -> Left "Empty Cookie" + where + kvPairs = fmap (both (T.dropAround (==' ')) . breakOnDiscard "=") . L.filter (not . T.null) . T.splitOn ";" + both f (x,y) = (f x, f y) + breakOnDiscard b = second (T.drop 1) . T.breakOn b diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2018, chessai + +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 chessai 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,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cookies.cabal b/cookies.cabal new file mode 100644 --- /dev/null +++ b/cookies.cabal @@ -0,0 +1,25 @@ +name: cookies +version: 0.1.0.0 +synopsis: web cookies +description: simple web cookies +homepage: https://github.com/chessai/cookies.git +license: BSD3 +license-file: LICENSE +author: Kyle McKean, chessai +maintainer: chessai +copyright: Copyright (c) Kyle McKean, chessai +category: Web +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.10 + +library + exposed-modules: Cookie + build-depends: + base >=4.7 && < 5.0 + , bytestring >= 0.10 + , chronos + , hashable + , text + , time + default-language: Haskell2010