Permalink
Browse files

Fixed up Gitit.CookieFixer to avoid warnings.

  • Loading branch information...
1 parent f1142c9 commit edbe31ea003003c1a67dcd5881920cceae6d35ca @jgm committed Jan 29, 2009
Showing with 4 additions and 22 deletions.
  1. +4 −22 Gitit/CookieFixer.hs
View
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
{- From the HAppSHelpers package v. 0.10.
(c) 2008 Thomas Hartman.
Needed only until HAppS fixes cookie parsing.
@@ -18,7 +19,7 @@ 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, (<|>))
+import Text.ParserCombinators.Parsec hiding (many, optional, (<|>), token)
instance Applicative (GenParser s a) where
pure = return
@@ -28,13 +29,10 @@ instance Alternative (GenParser s a) where
empty = mzero
(<|>) = mplus
--- Less complete but more robust way of parsing cookies. Note: not RFC 2068 compliant!
-parseCookies :: String -> [Cookie]
-parseCookies str = either (const []) id $ parse cookiesParser "" str
-
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)
@@ -58,15 +56,8 @@ cookiesParser = av_pairs
text = octet \\ ctl
qdtext = text \\ "\""
+cookie :: String -> String -> Cookie
cookie key value = Cookie "" "" "" (low key) value
-{-
-simpleHTTPCookieFixer :: ToMessage a => Conf -> [ServerPartT IO a] -> IO ()
-simpleHTTPCookieFixer conf hs
- = listen conf (\req -> runValidator (fromMaybe return (validator conf)) =<< simpleHTTP' hs (cookieFixer req))
-
-cookieFixer :: Request -> Request
-cookieFixer request = [ (cookieName c, c) | cl <- fromMaybe [] (fmap getCookies (getHeader "Cookie" (rqHeaders request))), c <- cl ]
--}
cookieFixer :: ServerPartT m a -> ServerPartT m a
cookieFixer (ServerPartT sp) = ServerPartT $ \request -> sp (request { rqCookies = (fixedCookies request) } )
@@ -80,14 +71,5 @@ getCookies :: Monad m => C.ByteString -> m [Cookie]
getCookies header | C.null header = return []
| otherwise = parseCookiesM (C.unpack header)
--- | Get the most specific cookie with the given name. Fails if there is no such
--- cookie or if the browser did not escape cookies in a proper fashion.
--- Browser support for escaping cookies properly is very diverse.
-getCookie :: Monad m => String -> C.ByteString -> m Cookie
-getCookie s h = do cs <- getCookies h
- case filter ((==) (low s) . cookieName) cs of
- [r] -> return r
- _ -> fail ("getCookie: " ++ show s)
-
low :: String -> String
low = map toLower

0 comments on commit edbe31e

Please sign in to comment.