packages feed

happstack-server 0.5.0 → 0.5.0.2

raw patch · 13 files changed

+77/−42 lines, 13 files

Files

happstack-server.cabal view
@@ -1,5 +1,5 @@ Name:                happstack-server-Version:             0.5.0+Version:             0.5.0.2 Synopsis:            Web related tools and services. Description:         Web framework License:             BSD3@@ -106,9 +106,9 @@ Executable happstack-server-tests   Main-Is: Test.hs   GHC-Options: -threaded-  Build-depends: HUnit, parsec < 4   hs-source-dirs: tests, src   if flag(tests)     Buildable: True+    Build-depends: HUnit, parsec < 4   else     Buildable: False
src/Happstack/Server/Cookie.hs view
@@ -37,9 +37,13 @@ -- | Set a Cookie in the Result. -- The values are escaped as per RFC 2109, but some browsers may -- have buggy support for cookies containing e.g. @\'\"\'@ or @\' \'@.+--+-- Also, it seems that chrome, safari, and other webkit browsers do+-- not like cookies which have double quotes around the domain and+-- reject/ignore the cookie. So, we no longer quote the domain. mkCookieHeader :: Seconds -> Cookie -> String mkCookieHeader sec cookie =-    let l = [("Domain=",s cookieDomain)+    let l = [("Domain=", cookieDomain cookie)             ,("Max-Age=",if sec < 0 then "" else show sec)             ,("Path=", cookiePath cookie)             ,("Version=", s cookieVersion)]
src/Happstack/Server/HTTP/FileServe.hs view
@@ -32,6 +32,7 @@      doIndexLazy,      doIndexStrict,      errorwrapper,+     fileNotFound,      isDot     ) where @@ -90,6 +91,7 @@ defaultIxFiles :: [String] defaultIxFiles= ["index.html","index.xml","index.gif"] +-- | return a simple "File not found 404 page." fileNotFound :: (Monad m, FilterMonad Response m) => FilePath -> m Response fileNotFound fp = return $ result 404 $ "File not found " ++ fp
src/Happstack/Server/HTTP/Handler.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-}+{-# LANGUAGE ScopedTypeVariables, ScopedTypeVariables #-}  module Happstack.Server.HTTP.Handler(request-- version,required   ,parseResponse,putRequest
src/Happstack/Server/HTTP/Listen.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, ScopedTypeVariables, PatternSignatures #-}+{-# LANGUAGE CPP, ScopedTypeVariables, ScopedTypeVariables #-} module Happstack.Server.HTTP.Listen(listen, listen',listenOn) where  import Happstack.Server.HTTP.Types
src/Happstack/Server/HTTP/Multipart.hs view
@@ -10,7 +10,7 @@ -- -- Maintainer  :  lemmih@vo.com -- Stability   :  experimental--- Portability :  xbnon-portable+-- Portability :  non-portable -- -- Parsing of the multipart format from RFC2046. -- Partly based on code from WASHMail.@@ -33,6 +33,7 @@      , splitAtEmptyLine     , splitAtCRLF+    , splitParts     ) where  import Control.Monad@@ -192,7 +193,6 @@               Nothing -> Nothing               Just j | BS.null (BS.drop (j+1) s) -> Just (j,1)               Just j -> case (BS.index s j, BS.index s (j+1)) of-                           ('\n','\r') -> Just (j,2)                            ('\r','\n') -> Just (j,2)                            _           -> Just (j,1) @@ -209,7 +209,6 @@ dropCRLF :: ByteString -> ByteString dropCRLF s | BS.null s = BS.empty            | BS.null (BS.drop 1 s) = BS.empty-           | c0 == '\n' && c1 == '\r' = BS.drop 2 s            | c0 == '\r' && c1 == '\n' = BS.drop 2 s            | otherwise = BS.drop 1 s   where c0 = BS.index s 0
src/Happstack/Server/HTTPClient/HTTP.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-}+{-# LANGUAGE ScopedTypeVariables, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module      :  Happstack.Server.HTTPClient.HTTP
src/Happstack/Server/HTTPClient/TCP.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-}+{-# LANGUAGE ScopedTypeVariables, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module      :  Happstack.Server.HTTPClient.TCP
src/Happstack/Server/Parts.hs view
@@ -128,10 +128,10 @@ encodings :: GenParser Char st [([Char], Maybe Double)] encodings = ws >> (encoding1 `sepBy` try sep) >>= (\x -> ws >> eof >> return x)     where-        ws = many space+        ws = many space >> return ()         sep = do             ws-            char ','+            _ <- char ','             ws                  encoding1 :: GenParser Char st ([Char], Maybe Double)@@ -155,7 +155,7 @@                 return fractionalPart         fraction :: GenParser Char st String         fraction = do-            char '.'+            _ <- char '.'             fractionalPart<-option "" int             return $ '.':fractionalPart
src/Happstack/Server/SimpleHTTP.hs view
@@ -9,7 +9,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE PatternSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}  {-# OPTIONS -fno-warn-orphans #-} -----------------------------------------------------------------------------@@ -126,7 +126,7 @@     -- * Type Classes     , FromReqURI(..)     , ToMessage(..)-+    , toResponseBS       -- * Manipulating requests     , FromData(..)     , ServerMonad(..)@@ -142,10 +142,18 @@     , SetAppend(..)     , FilterT(..)     , WebMonad(..)-    , ok+    , addCookie+    , addCookies+    , expireCookie+    , addHeaderM+    , setHeaderM+    , ifModifiedSince     , modifyResponse-    , toResponseBS     , setResponseCode+    , resp++      -- * Respond Codes+    , ok     , badGateway     , internalServerError     , badRequest@@ -156,12 +164,6 @@     , found     , movedPermanently     , tempRedirect-    , addCookie-    , addCookies-    , expireCookie-    , addHeaderM-    , setHeaderM-    , ifModifiedSince       -- * guards and building blocks     , guardRq@@ -326,12 +328,12 @@ -- that demands a @ServerPartT IO a@ (e.g. 'simpleHTTP').  You -- can provide the function: ----- >   unpackErrorT:: (Monad m, Show e) => UnWebT (ErrorT e m) a -> UnWebT m a--- >   unpackErrorT handler et = do+-- >   unpackErrorT :: (Monad m, Show e) => UnWebT (ErrorT e m) a -> UnWebT m a+-- >   unpackErrorT et = do -- >      eitherV <- runErrorT et -- >      return $ case eitherV of--- >          Left err -> Just (Left "Catastrophic failure " ++ show e--- >                           , Set $ Endo $ \r -> r{rsCode = 500})+-- >          Left err -> Just (Left $ toResponse $ "Catastrophic failure " ++ show err+-- >                           , Set $ Dual $ Endo $ \r -> r{rsCode = 500}) -- >          Right x -> x -- -- With @unpackErrorT@ you can now call 'simpleHTTP'. Just wrap your @ServerPartT@ list.@@ -1104,16 +1106,6 @@               setHeader "Content-Length" (show $ L.length new) $               res { rsBody = new } --- | Deprecated:  use 'composeFilter'.-modifyResponse :: (FilterMonad a m) => (a -> a) -> m()-modifyResponse = composeFilter-{-# DEPRECATED modifyResponse "Use composeFilter" #-}---- | Set the return code in your response.-setResponseCode :: FilterMonad Response m => Int -> m ()-setResponseCode code-    = composeFilter $ \r -> r{rsCode = code}- -- | Add the cookie with a timeout to the response. addCookie :: (FilterMonad Response m) => Seconds -> Cookie -> m () addCookie sec = (addHeaderM "Set-Cookie") . mkCookieHeader sec@@ -1141,6 +1133,16 @@           then result 304 "" -- Not Modified           else setHeader "Last-modified" repr response +-- | Deprecated:  use 'composeFilter'.+modifyResponse :: (FilterMonad a m) => (a -> a) -> m()+modifyResponse = composeFilter+{-# DEPRECATED modifyResponse "Use composeFilter" #-}++-- | Set the return code in your response.+setResponseCode :: FilterMonad Response m => Int -> m ()+setResponseCode code+    = composeFilter $ \r -> r{rsCode = code}+ -- | Same as @'setResponseCode' status >> return val@. resp :: (FilterMonad Response m) => Int -> b -> m b resp status val = setResponseCode status >> return val@@ -1199,7 +1201,7 @@ {-# DEPRECATED multi "Use msum instead" #-}  -- | What is this for, exactly?  I don't understand why @Show a@ is even in the context--- This appears to do nothing at all.+-- Deprecated: This function appears to do nothing at all. If it use it, let us know why. debugFilter :: (MonadIO m, Show a) => ServerPartT m a -> ServerPartT m a debugFilter handle =     withRequest $ \rq -> do@@ -1211,6 +1213,7 @@ anyRequest x = withRequest $ \_ -> x  -- | Again, why is this useful?+-- Deprecated: No idea why this function would be useful. If you use it, please tell us. applyRequest :: (ToMessage a, Monad m, Functor m) =>                 ServerPartT m a -> Request -> Either (m Response) b applyRequest hs = simpleHTTP'' hs >>= return . Left
src/Happstack/Server/StdConfig.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} module Happstack.Server.StdConfig where  import Control.Monad.Trans
src/Happstack/Server/XSLT.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell, FlexibleInstances , UndecidableInstances,              DeriveDataTypeable, MultiParamTypeClasses, CPP, ScopedTypeVariables,-    PatternSignatures #-}+    ScopedTypeVariables #-} module Happstack.Server.XSLT     (xsltFile, xsltString, xsltElem, xsltFPS, xsltFPSIO, XSLPath,      xsltproc,saxon,procFPSIO,procLBSIO,XSLTCommand,XSLTCmd
tests/Happstack/Server/Tests.hs view
@@ -1,15 +1,20 @@ -- |HUnit tests and QuickQuick properties for Happstack.Server.* module Happstack.Server.Tests (allTests) where -import Test.HUnit as HU (Test(..),(~:),(~?),(@?=))+import Test.HUnit as HU (Test(..),(~:),(~?),(@?=),(@=?)) import Happstack.Server.Cookie import Happstack.Server.Parts import Text.ParserCombinators.Parsec+import Data.ByteString.Lazy.Char8 (pack)+import Happstack.Server.HTTP.Multipart  -- |All of the tests for happstack-util should be listed here.  allTests :: Test allTests = -    "happstack-server tests" ~: [cookieParserTest, acceptEncodingParserTest]+    "happstack-server tests" ~: [ cookieParserTest+                                , acceptEncodingParserTest+                                , splitMultipart +                                ]  cookieParserTest :: Test cookieParserTest = @@ -47,3 +52,25 @@        , (" gzip;q=1.0, identity; q=0.5, *;q=0", [("gzip", Just 1.0), ("identity",Just 0.5), ("*", Just 0)])        , (" x-gzip",[("x-gzip", Nothing)])        ]++splitMultipart :: Test+splitMultipart =+    "split multipart" ~: +    [ Just [pack "1"] @=? +           splitParts (pack "boundary")+                      (pack "beg\r\n--boundary\r\n1\r\n--boundary--\r\nend")+    , Just [pack "1\n"] @=? +           splitParts (pack "boundary")+                      (pack "beg\r\n--boundary\r\n1\n\r\n--boundary--\r\nend")+    , Just [pack "1\r\n"] @=? +           splitParts (pack "boundary")+                      (pack "beg\r\n--boundary\r\n1\r\n\r\n--boundary--\r\nend")+    , Just [pack "1\n\r"] @=? +           splitParts (pack "boundary")+                      (pack "beg\r\n--boundary\r\n1\n\r\r\n--boundary--\r\nend")+    , Just [pack "\r\n1\n\r"] @=? +           splitParts (pack "boundary")+                      (pack "beg\r\n--boundary\r\n\r\n1\n\r\r\n--boundary--\r\nend")+    ]++