Permalink
Browse files

Moved cookieFixer into Gitit/HAppS.hs, removed Gitit/CookieFixer.hs.

  • Loading branch information...
1 parent f87905e commit 4bca52bf33176824bb1196a09a73a2d312c821ee @jgm committed Jan 30, 2009
Showing with 73 additions and 80 deletions.
  1. +1 −2 Gitit.hs
  2. +0 −75 Gitit/CookieFixer.hs
  3. +71 −2 Gitit/HAppS.hs
  4. +1 −1 gitit.cabal
View
@@ -20,10 +20,9 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
module Main where
import HAppS.Server hiding (look, lookRead, lookCookieValue, mkCookie)
-import Gitit.HAppS (look, lookRead, lookCookieValue, mkCookie)
+import Gitit.HAppS (look, lookRead, lookCookieValue, mkCookie, cookieFixer)
import Gitit.Util (withTempDir, orIfNull, consolidateHeads)
import Gitit.Initialize (createStaticIfMissing, createRepoIfMissing)
-import Gitit.CookieFixer (cookieFixer)
import System.IO.UTF8
import System.IO (stderr)
import Control.Exception (throwIO, catch, try)
View
@@ -1,75 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-{- From the HAppSHelpers package v. 0.10.
- (c) 2008 Thomas Hartman.
- Needed only until HAppS fixes cookie parsing.
--}
-
-module Gitit.CookieFixer
- ( cookieFixer
- ) where
-
-import HAppS.Server.Cookie (Cookie(..))
-import HAppS.Server(ServerPartT(..),Request(..), getHeader)
-
-import qualified Data.ByteString.Char8 as C
-import Data.Char (chr, toLower)
-import Data.List ((\\))
-import Data.Maybe
-
-import Control.Applicative
-import Control.Monad (MonadPlus(..), ap)
--- Hide Parsec's definitions of some Applicative functions.
-import Text.ParserCombinators.Parsec hiding (many, optional, (<|>), token)
-
-instance Applicative (GenParser s a) where
- pure = return
- (<*>) = ap
-
-instance Alternative (GenParser s a) where
- empty = mzero
- (<|>) = mplus
-
-parseCookiesM :: (Monad m) => String -> m [Cookie]
-parseCookiesM str = either (fail "Invalid cookie syntax!") return $ parse cookiesParser str str
-
-cookiesParser :: GenParser Char st [Cookie]
-cookiesParser = av_pairs
- where -- Parsers based on RFC 2109
- av_pairs = (:) <$> av_pair <*> many (char ';' *> av_pair)
- av_pair = cookie <$> attr <*> option "" (char '=' *> value)
- attr = spaces *> token
- value = word
- word = incomp_token <|> quoted_string
-
- -- Parsers based on RFC 2068
- token = many1 $ oneOf ((chars \\ ctl) \\ tspecials)
- quoted_string = char '"' *> many (oneOf qdtext) <* char '"'
-
- -- Custom parser, incompatible with RFC 2068, but very forgiving ;)
- incomp_token = many1 $ oneOf ((chars \\ ctl) \\ "\";")
-
- -- Primitives from RFC 2068
- tspecials = "()<>@,;:\\\"/[]?={} \t"
- ctl = map chr (127:[0..31])
- chars = map chr [0..127]
- octet = map chr [0..255]
- text = octet \\ ctl
- qdtext = text \\ "\""
-
-cookie :: String -> String -> Cookie
-cookie key value = Cookie "" "" "" (low key) value
-
-cookieFixer :: ServerPartT m a -> ServerPartT m a
-cookieFixer (ServerPartT sp) = ServerPartT $ \request -> sp (request { rqCookies = (fixedCookies request) } )
- where
- fixedCookies request = [ (cookieName c, c) | cl <- fromMaybe [] (fmap getCookies (getHeader "Cookie" (rqHeaders request))), c <- cl ]
-
--- | Get all cookies from the HTTP request. The cookies are ordered per RFC from
--- the most specific to the least specific. Multiple cookies with the same
--- name are allowed to exist.
-getCookies :: Monad m => C.ByteString -> m [Cookie]
-getCookies header | C.null header = return []
- | otherwise = parseCookiesM (C.unpack header)
-
-low :: String -> String
-low = map toLower
View
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
{-
Copyright (C) 2008 John MacFarlane <jgm@berkeley.edu>
@@ -16,22 +17,33 @@ along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
-{- Replacements for HAppS functions that don't handle UTF-8 properly.
+{- Replacements for HAppS functions that don't handle UTF-8 properly,
+ and a fix for broken HAppS cookie parsing.
-}
module Gitit.HAppS
( look
, lookRead
, lookCookieValue
, mkCookie
+ , cookieFixer
)
where
-import HAppS.Server hiding (look, lookRead, lookCookieValue, mkCookie)
+import HAppS.Server hiding (look, lookRead, lookCookieValue, mkCookie, getCookies)
import qualified HAppS.Server (lookCookieValue, mkCookie)
+import HAppS.Server.Cookie (Cookie(..))
import Text.Pandoc.CharacterReferences (decodeCharacterReferences)
import Control.Monad (liftM)
import Data.ByteString.Lazy.UTF8 (toString)
import Codec.Binary.UTF8.String (encodeString, decodeString)
+import qualified Data.ByteString.Char8 as C
+import Data.Char (chr, toLower)
+import Data.List ((\\))
+import Data.Maybe
+import Control.Applicative
+import Control.Monad (MonadPlus(..), ap)
+-- Hide Parsec's definitions of some Applicative functions.
+import Text.ParserCombinators.Parsec hiding (many, optional, (<|>), token)
-- Contents of an HTML text area or text field generated by Text.XHtml
-- will often contain decimal character references. We want to convert these
@@ -49,3 +61,60 @@ lookCookieValue = liftM decodeString . HAppS.Server.lookCookieValue
mkCookie :: String -> String -> Cookie
mkCookie name = HAppS.Server.mkCookie name . encodeString
+
+----- the following code is from the HAppSHelpers package, 0.10,
+----- (C) 2008 Thomas Hartman.
+----- Needed until HAppS Server cookie parsing is fixed.
+
+instance Applicative (GenParser s a) where
+ pure = return
+ (<*>) = ap
+
+instance Alternative (GenParser s a) where
+ empty = mzero
+ (<|>) = mplus
+
+parseCookiesM :: (Monad m) => String -> m [Cookie]
+parseCookiesM str = either (fail "Invalid cookie syntax!") return $ parse cookiesParser str str
+
+cookiesParser :: GenParser Char st [Cookie]
+cookiesParser = av_pairs
+ where -- Parsers based on RFC 2109
+ av_pairs = (:) <$> av_pair <*> many (char ';' *> av_pair)
+ av_pair = cookie <$> attr <*> option "" (char '=' *> value)
+ attr = spaces *> token
+ value = word
+ word = incomp_token <|> quoted_string
+
+ -- Parsers based on RFC 2068
+ token = many1 $ oneOf ((chars \\ ctl) \\ tspecials)
+ quoted_string = char '"' *> many (oneOf qdtext) <* char '"'
+
+ -- Custom parser, incompatible with RFC 2068, but very forgiving ;)
+ incomp_token = many1 $ oneOf ((chars \\ ctl) \\ "\";")
+
+ -- Primitives from RFC 2068
+ tspecials = "()<>@,;:\\\"/[]?={} \t"
+ ctl = map chr (127:[0..31])
+ chars = map chr [0..127]
+ octet = map chr [0..255]
+ text = octet \\ ctl
+ qdtext = text \\ "\""
+
+cookie :: String -> String -> Cookie
+cookie key value = Cookie "" "" "" (low key) value
+
+cookieFixer :: ServerPartT m a -> ServerPartT m a
+cookieFixer (ServerPartT sp) = ServerPartT $ \request -> sp (request { rqCookies = (fixedCookies request) } )
+ where
+ fixedCookies request = [ (cookieName c, c) | cl <- fromMaybe [] (fmap getCookies (getHeader "Cookie" (rqHeaders request))), c <- cl ]
+
+-- | Get all cookies from the HTTP request. The cookies are ordered per RFC from
+-- the most specific to the least specific. Multiple cookies with the same
+-- name are allowed to exist.
+getCookies :: Monad m => C.ByteString -> m [Cookie]
+getCookies header | C.null header = return []
+ | otherwise = parseCookiesM (C.unpack header)
+
+low :: String -> String
+low = map toLower
View
@@ -43,7 +43,7 @@ Executable gitit
hs-source-dirs: .
main-is: Gitit.hs
other-modules: Gitit.State, Gitit.HAppS, Gitit.MimeTypes, Gitit.Util,
- Gitit.Initialize, Gitit.Config, Gitit.CookieFixer, Paths_gitit
+ Gitit.Initialize, Gitit.Config, Paths_gitit
build-depends: base >=3, parsec < 3, pretty, xhtml, containers, pandoc
>= 1.1, process, filepath, directory, mtl, cgi,
network, old-time, highlighting-kate, bytestring,

0 comments on commit 4bca52b

Please sign in to comment.