diff --git a/Network/Web/HTTP.hs b/Network/Web/HTTP.hs --- a/Network/Web/HTTP.hs +++ b/Network/Web/HTTP.hs @@ -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 () diff --git a/Network/Web/Params.hs b/Network/Web/Params.hs --- a/Network/Web/Params.hs +++ b/Network/Web/Params.hs @@ -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 diff --git a/Network/Web/Server.hs b/Network/Web/Server.hs --- a/Network/Web/Server.hs +++ b/Network/Web/Server.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/Web/Server/Basic.hs b/Network/Web/Server/Basic.hs --- a/Network/Web/Server/Basic.hs +++ b/Network/Web/Server/Basic.hs @@ -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 diff --git a/Network/Web/Server/CGI.hs b/Network/Web/Server/CGI.hs --- a/Network/Web/Server/CGI.hs +++ b/Network/Web/Server/CGI.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/Web/Server/Lang.hs b/Network/Web/Server/Lang.hs --- a/Network/Web/Server/Lang.hs +++ b/Network/Web/Server/Lang.hs @@ -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 diff --git a/Network/Web/Server/Range.hs b/Network/Web/Server/Range.hs --- a/Network/Web/Server/Range.hs +++ b/Network/Web/Server/Range.hs @@ -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)) diff --git a/Parsec.hs b/Parsec.hs new file mode 100644 --- /dev/null +++ b/Parsec.hs @@ -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 diff --git a/webserver.cabal b/webserver.cabal --- a/webserver.cabal +++ b/webserver.cabal @@ -1,5 +1,5 @@ Name: webserver -Version: 0.4.0 +Version: 0.4.1 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto 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