diff --git a/happstack-server.cabal b/happstack-server.cabal --- a/happstack-server.cabal +++ b/happstack-server.cabal @@ -1,5 +1,5 @@ Name: happstack-server -Version: 7.1.6 +Version: 7.1.7 Synopsis: Web related tools and services. Description: Happstack Server provides an HTTP server and a rich set of functions for routing requests, handling query parameters, generating responses, working with cookies, serving files, and more. For in-depth documentation see the Happstack Crash Course License: BSD3 diff --git a/src/Happstack/Server/FileServe/BuildingBlocks.hs b/src/Happstack/Server/FileServe/BuildingBlocks.hs --- a/src/Happstack/Server/FileServe/BuildingBlocks.hs +++ b/src/Happstack/Server/FileServe/BuildingBlocks.hs @@ -55,7 +55,7 @@ ) where import Control.Applicative ((<$>)) -import Control.Exception.Extensible (IOException, bracket, catch) +import Control.Exception.Extensible as E (IOException, bracket, catch) import Control.Monad (MonadPlus(mzero), msum) import Control.Monad.Trans (MonadIO(liftIO)) import qualified Data.ByteString.Lazy.Char8 as L @@ -71,7 +71,6 @@ import Happstack.Server.Monads (ServerMonad(askRq), FilterMonad, WebMonad) import Happstack.Server.Response (ToMessage(toResponse), ifModifiedSince, forbidden, ok, seeOther) import Happstack.Server.Types (Length(ContentLength), Request(rqPaths, rqUri), Response(SendFile), RsFlags(rsfLength), nullRsFlags, result, resultBS, setHeader) -import Prelude hiding (catch) import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents, getModificationTime) import System.FilePath ((), addTrailingPathSeparator, hasDrive, isPathSeparator, joinPath, takeExtension, isValid) import System.IO (IOMode(ReadMode), hFileSize, hClose, openBinaryFile, withBinaryFile) @@ -610,13 +609,13 @@ -> IO (FilePath, Maybe UTCTime, Maybe Integer, EntryKind) getMetaData localPath fp = do let localFp = localPath fp - modTime <- (Just . toUTCTime <$> getModificationTime localFp) `catch` + modTime <- (Just . toUTCTime <$> getModificationTime localFp) `E.catch` (\(_ :: IOException) -> return Nothing) count <- do de <- doesDirectoryExist localFp if de then do return Nothing else do bracket (openBinaryFile localFp ReadMode) hClose (fmap Just . hFileSize) - `catch` (\(_e :: IOException) -> return Nothing) + `E.catch` (\(_e :: IOException) -> return Nothing) kind <- do fe <- doesFileExist localFp if fe then return File diff --git a/src/Happstack/Server/Internal/TimeoutSocket.hs b/src/Happstack/Server/Internal/TimeoutSocket.hs --- a/src/Happstack/Server/Internal/TimeoutSocket.hs +++ b/src/Happstack/Server/Internal/TimeoutSocket.hs @@ -5,7 +5,7 @@ module Happstack.Server.Internal.TimeoutSocket where import Control.Concurrent (threadWaitWrite) -import Control.Exception (catch, throw) +import Control.Exception as E (catch, throw) import Control.Monad (liftM, when) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as L @@ -18,7 +18,6 @@ import Network.Socket (Socket, ShutdownCmd(..), shutdown) import Network.Socket.SendFile (Iter(..), ByteCount, Offset, sendFileIterWith') import Network.Socket.ByteString (sendAll) -import Prelude hiding (catch) import System.IO.Error (isDoesNotExistError) import System.IO.Unsafe (unsafeInterleaveIO) @@ -42,7 +41,7 @@ s <- N.recv sock 65536 TM.tickle handle if S.null s - then do shutdown sock ShutdownReceive `catch` (\e -> when (not $ isDoesNotExistError e) (throw e)) + then do shutdown sock ShutdownReceive `E.catch` (\e -> when (not $ isDoesNotExistError e) (throw e)) return L.Empty else L.Chunk s `liftM` loop diff --git a/src/Happstack/Server/Internal/Types.hs b/src/Happstack/Server/Internal/Types.hs --- a/src/Happstack/Server/Internal/Types.hs +++ b/src/Happstack/Server/Internal/Types.hs @@ -81,7 +81,7 @@ (rsfLength (rsFlags rs) /= NoContentLength || isNoMessageBodyResponse rs)) where isNoMessageBodyCode code = (code >= 100 && code <= 199) || code == 204 || code == 304 - isNoMessageBodyResponse rs = isNoMessageBodyCode (rsCode rs) && L.null (rsBody rs) + isNoMessageBodyResponse rs' = isNoMessageBodyCode (rsCode rs') && L.null (rsBody rs') -- | function to log access requests (see also: 'logMAccess') -- type LogAccess time = diff --git a/src/Happstack/Server/SURI.hs b/src/Happstack/Server/SURI.hs --- a/src/Happstack/Server/SURI.hs +++ b/src/Happstack/Server/SURI.hs @@ -1,13 +1,32 @@ {-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TypeSynonymInstances #-} --- | A wrapper and type class so that functions like 'seeOther' can take a URI which is represented by a 'String', 'URI.URI', or other instance of 'ToSURI'. -module Happstack.Server.SURI where +-- | A wrapper and type class so that functions like 'seeOther' can take a URI which is represented by a 'String', 'URI.URI', or other instance of 'ToSURI'. +module Happstack.Server.SURI + ( path + , query + , scheme + , u_scheme + , u_path + , a_scheme + , a_path + , percentDecode + , unEscape + , unEscapeQS + , isAbs + , SURI(..) + , render + , parse + , ToSURI(..) + , FromPath(..) + ) + where import Control.Arrow (first) -import Data.Maybe -import Data.Generics -import qualified Data.Text as Text +import Data.Char (chr, digitToInt, isHexDigit) +import Data.Maybe (fromJust, isJust) +import Data.Generics (Data, Typeable) +import qualified Data.Text as Text import qualified Data.Text.Lazy as LazyText -import qualified Network.URI as URI +import qualified Network.URI as URI -- | Retrieves the path component from the URI path :: SURI -> String @@ -37,11 +56,20 @@ a_path :: String -> SURI -> SURI a_path a (SURI u) = SURI $ u {URI.uriPath=a} -escape, unEscape, unEscapeQS :: String -> String -unEscapeQS = URI.unEscapeString . map (\x->if x=='+' then ' ' else x) -unEscape = URI.unEscapeString -escape = URI.escapeURIString URI.isAllowedInURI +-- | percent decode a String +-- +-- e.g. @\"hello%2Fworld\"@ -> @\"hello/world\"@ +percentDecode :: String -> String +percentDecode [] = "" +percentDecode ('%':x1:x2:s) | isHexDigit x1 && isHexDigit x2 = + chr (digitToInt x1 * 16 + digitToInt x2) : percentDecode s +percentDecode (c:s) = c : percentDecode s +unEscape, unEscapeQS :: String -> String +unEscapeQS = percentDecode . map (\x->if x=='+' then ' ' else x) +unEscape = percentDecode +-- escape = URI.escapeURIString URI.isAllowedInURI + -- | Returns true if the URI is absolute isAbs :: SURI -> Bool isAbs = not . null . URI.uriScheme . suri @@ -50,7 +78,7 @@ instance Show SURI where showsPrec d (SURI uri) = showsPrec d $ show uri instance Read SURI where - readsPrec d = mapFst fromJust . filter (isJust . fst) . mapFst parse . readsPrec d + readsPrec d = mapFst fromJust . filter (isJust . fst) . mapFst parse . readsPrec d where mapFst :: (a -> b) -> [(a,x)] -> [(b,x)] mapFst = map . first @@ -64,14 +92,14 @@ -- | Parses a URI from a String. Returns Nothing on failure. parse :: String -> Maybe SURI -parse = fmap SURI . URI.parseURIReference +parse = fmap SURI . URI.parseURIReference -- | Convenience class for converting data types to URIs class ToSURI x where toSURI::x->SURI instance ToSURI SURI where toSURI=id instance ToSURI URI.URI where toSURI=SURI -instance ToSURI String where +instance ToSURI String where toSURI = maybe (SURI $ URI.URI "" Nothing "" "" "") id . parse instance ToSURI Text.Text where toSURI = toSURI . Text.unpack instance ToSURI LazyText.Text where toSURI = toSURI . LazyText.unpack