webserver 0.4.0 → 0.4.1
raw patch · 9 files changed
+75/−24 lines, 9 filesdep ~parsecPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: parsec
API changes (from Hackage documentation)
Files
- Network/Web/HTTP.hs +4/−4
- Network/Web/Params.hs +6/−5
- Network/Web/Server.hs +2/−2
- Network/Web/Server/Basic.hs +2/−2
- Network/Web/Server/CGI.hs +2/−1
- Network/Web/Server/Lang.hs +1/−3
- Network/Web/Server/Range.hs +2/−4
- Parsec.hs +52/−0
- webserver.cabal +4/−3
Network/Web/HTTP.hs view
@@ -17,15 +17,16 @@ import Control.Applicative import Control.Exception (try, throw)+import Control.Monad import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import Data.Char import qualified Data.Map as M import Data.Maybe import IO hiding (try)-import System.IO.Error hiding (try) import Network.Web.Params import Network.Web.URI+import System.IO.Error hiding (try) import Text.Printf ----------------------------------------------------------------@@ -253,9 +254,8 @@ Just len -> S.hPutStr hdl $ composeField (FkContentLength, S.pack (show len)) Nothing -> return () putTransferEncoding =- if ver == HTTP11 && isJust (rspBody rsp) && isNothing (rspLength rsp)- then S.hPutStr hdl $ composeField (FkTransferEncoding, "chunked")- else return ()+ when (ver == HTTP11 && isJust (rspBody rsp) && isNothing (rspLength rsp)) $+ S.hPutStr hdl $ composeField (FkTransferEncoding, "chunked") putConnection = S.hPutStr hdl $ composeField (FkConnection, fromPersist persist) sendResponseBody :: Handle -> Version -> Response -> IO ()
Network/Web/Params.hs view
@@ -19,6 +19,7 @@ import qualified Data.ByteString.Char8 as S import Data.Char import qualified Data.Map as M+import Data.Maybe import Data.Typeable ----------------------------------------------------------------@@ -34,7 +35,7 @@ in zip (map (S.pack . show) methods) methods toMethod :: S.ByteString -> Method-toMethod s = maybe UnknownMethod id $ lookup s methodAlist+toMethod s = fromMaybe UnknownMethod $ lookup s methodAlist ---------------------------------------------------------------- @@ -133,7 +134,7 @@ Returning 'True' for 4xx and 5xx. -} badStatus :: Status -> Bool-badStatus status = n == '4' || n == '5'+badStatus status = n `elem` "45" where n:_ = show status @@ -218,7 +219,7 @@ Converting field key to 'FieldKey'. -} toFieldKey :: S.ByteString -> FieldKey-toFieldKey str = maybe (FkOther cstr) id $ M.lookup cstr stringFieldKey+toFieldKey str = fromMaybe (FkOther cstr) $ M.lookup cstr stringFieldKey where cstr = capitalize str @@ -227,7 +228,7 @@ -} fromFieldKey :: FieldKey -> S.ByteString fromFieldKey (FkOther cstr) = cstr-fromFieldKey key = maybe err id $ M.lookup key fieldKeyString+fromFieldKey key = fromMaybe err $ M.lookup key fieldKeyString where err = error "fromFieldKey" @@ -265,7 +266,7 @@ -} selectContentType :: String -> CT selectContentType "" = textPlain-selectContentType ext = maybe appOct id (lookup lext contentTypeDB)+selectContentType ext = fromMaybe appOct $ lookup lext contentTypeDB where lext = map toLower ext
Network/Web/Server.hs view
@@ -61,14 +61,14 @@ rsp <- runServer svr mreq persist <- sendResponse hdl cnf rsp mreq case persist of- Close -> closedHook cnf $ "Connection is closed"+ Close -> closedHook cnf "Connection is closed" Keep -> session hdl svr cnf _ -> return () -- never reached where runServer server mreq = do date <- utcToDate <$> getCurrentTime addDate date <$> server mreq- addDate date rsp = insertField FkDate date rsp+ addDate = insertField FkDate ----------------------------------------------------------------
Network/Web/Server/Basic.hs view
@@ -57,7 +57,7 @@ _ -> adjust <$> pure responseNotImplement where adjust = addServer . addPeerToLog- addServer rsp = insertField FkServer (serverName cnf) rsp+ addServer = insertField FkServer (serverName cnf) addPeerToLog rsp = rsp { rspLogMsg = logmsg} peer = peerAddr (tcpInfo cnf) logmsg = "[" ++ peer ++ "] " ++ maybe "" uri mreq@@ -98,7 +98,7 @@ , notFound ] -- always Just processPOST :: BasicConfig -> Request -> IO Response-processPOST cnf req = tryPost cnf req+processPOST = tryPost languages :: Request -> [String] languages req = maybe [] (parseLang . S.unpack) $ lookupField FkAcceptLanguage req
Network/Web/Server/CGI.hs view
@@ -6,6 +6,7 @@ import Control.Concurrent import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L+import Data.Maybe import Network.TCPInfo import Network.Web.HTTP import Network.Web.Server.Params@@ -82,7 +83,7 @@ case lookupField' FkContentType flds of Nothing -> return responseInternalServerError Just _ -> do- let st = maybe OK id (lookupField' FkStatus flds >>= toStatus)+ let st = fromMaybe OK (lookupField' FkStatus flds >>= toStatus) responseAny st flds <$> L.hGetContents rhdl ----------------------------------------------------------------
Network/Web/Server/Lang.hs view
@@ -1,10 +1,8 @@ module Network.Web.Server.Lang (parseLang) where -import Control.Applicative ((<$>),(<$),(<*>),(*>)) import Data.List import Data.Ord-import Text.Parsec-import Text.Parsec.String+import Parsec parseLang :: String -> [String] parseLang xs = case parse acceptLanguage "" xs of
Network/Web/Server/Range.hs view
@@ -1,8 +1,6 @@ module Network.Web.Server.Range (skipAndSize) where -import Control.Applicative ((<$>),(<*),(<*>),(*>))-import Text.Parsec-import Text.Parsec.String+import Parsec skipAndSize :: String -> Integer -> Maybe (Integer,Integer) skipAndSize str size = case parseRange str of@@ -36,7 +34,7 @@ range :: Parser Range range = (,) <$> ((Just <$> num) <* char '-')- <*> (option Nothing (Just <$> num))+ <*> option Nothing (Just <$> num) suffixRange :: Parser Range suffixRange = (,) Nothing <$> (char '-' *> (Just <$> num))
+ Parsec.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE CPP #-}++#ifndef MIN_VERSION_parsec+#define MIN_VERSION_parsec(x,y,z) 0+#endif++#if MIN_VERSION_parsec(3,0,0)+module Parsec (+ module Control.Applicative+ , module Text.Parsec+ , module Text.Parsec.String+ ) where++import Control.Applicative hiding (many,optional,(<|>))+import Text.Parsec+import Text.Parsec.String+#else+module Parsec (+ module Text.ParserCombinators.Parsec+ , (<$>), (<$), (<*>), (<*), (*>), pure+ ) where++import Control.Monad (ap, liftM)+import Text.ParserCombinators.Parsec++{-+ GenParser cannot be an instance of Applicative and Alternative+ due to the overlapping instances error, sigh!+-}++(<$>) :: Monad m => (a -> b) -> m a -> m b+(<$>) = liftM++(<$) :: Monad m => a -> m b -> m a+a <$ m = m >> return a++(<*>) :: Monad m => m (a -> b) -> m a -> m b+(<*>) = ap++(*>) :: Monad m => m a -> m b -> m b+(*>) = (>>)++(<*) :: Monad m => m a -> m b -> m a+m1 <* m2 = do x <- m1+ m2+ return x++pure :: Monad m => a -> m a+pure = return++infixl 4 <$>, <$, <*>, <*, *>+#endif
webserver.cabal view
@@ -1,5 +1,5 @@ Name: webserver-Version: 0.4.0+Version: 0.4.1 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3@@ -18,13 +18,14 @@ Network.Web.Server Network.Web.Server.Basic Network.Web.URI- Other-Modules: Network.Web.Date+ Other-Modules: Parsec+ Network.Web.Date Network.Web.Params Network.Web.Server.CGI Network.Web.Server.Lang Network.Web.Server.Params Network.Web.Server.Range- Build-Depends: base >= 4 && < 5, parsec >= 3,+ Build-Depends: base >= 4 && < 5, parsec, haskell98, network, bytestring, containers, filepath, time, unix, process, c10k Source-Repository head