happstack-server 7.7.2 → 7.9.3
raw patch · 18 files changed
Files
- README.md +1/−1
- happstack-server.cabal +24/−12
- src/Happstack/Server/Cookie.hs +4/−4
- src/Happstack/Server/Error.hs +5/−5
- src/Happstack/Server/FileServe/BuildingBlocks.hs +9/−12
- src/Happstack/Server/Internal/Clock.hs +2/−9
- src/Happstack/Server/Internal/Cookie.hs +12/−13
- src/Happstack/Server/Internal/Listen.hs +2/−1
- src/Happstack/Server/Internal/LogFormat.hs +0/−5
- src/Happstack/Server/Internal/Monads.hs +16/−56
- src/Happstack/Server/Internal/Types.hs +12/−11
- src/Happstack/Server/Monads.hs +6/−2
- src/Happstack/Server/Response.hs +8/−7
- src/Happstack/Server/Routing.hs +1/−1
- src/Happstack/Server/RqData.hs +53/−14
- src/Happstack/Server/SURI.hs +2/−2
- src/Happstack/Server/SimpleHTTP.hs +3/−2
- tests/Happstack/Server/Tests.hs +20/−7
README.md view
@@ -1,4 +1,4 @@-# happstack-server [][hackage] [](https://travis-ci.com/Happstack/happstack-server)+# happstack-server [][hackage] [hackage]: https://hackage.haskell.org/package/happstack-server
happstack-server.cabal view
@@ -1,5 +1,5 @@ Name: happstack-server-Version: 7.7.2+Version: 7.9.3 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 <http://happstack.com/docs/crashcourse/index.html> License: BSD3@@ -11,8 +11,23 @@ Build-Type: Simple Cabal-Version: >= 1.10 Extra-Source-Files: tests/Happstack/Server/Tests.hs README.md-tested-with: GHC==8.0.1, GHC==8.2.2, GHC==8.4.1, GHC==8.6.5, GHC==8.8.3, GHC==8.10.1, GHC==9.0.1 +tested-with:+ GHC == 9.14.1+ GHC == 9.12.2+ GHC == 9.10.2+ GHC == 9.8.2+ GHC == 9.6.7+ GHC == 9.4.8+ GHC == 9.2.8+ GHC == 9.0.2+ GHC == 8.10.7+ GHC == 8.8.4+ GHC == 8.6.5+ GHC == 8.4.4+ GHC == 8.2.2+ GHC == 8.0.2+ source-repository head type: git location: https://github.com/Happstack/happstack-server.git@@ -62,7 +77,7 @@ Paths_happstack_server if flag(network-uri)- build-depends: network >= 3.0.0 && < 3.2,+ build-depends: network >= 3.0.0 && < 3.3, network-uri >= 2.6 && < 2.7 else build-depends: network < 2.6@@ -77,23 +92,20 @@ filepath, hslogger >= 1.0.2, html,- monad-control >= 0.3 && < 1.1,- mtl >= 2 && < 2.3,- old-locale,+ monad-control >= 1.0 && < 1.1,+ mtl >= 2.2 && < 2.4, parsec < 4, process,- semigroups >= 0.16, sendfile >= 0.7.1 && < 0.8, system-filepath >= 0.3.1, syb,- text >= 0.10 && < 2.1,- time,+ text >= 0.10 && < 2.2,+ time >= 1.5, threads >= 0.5, transformers >= 0.1.3 && < 0.7, transformers-base >= 0.4 && < 0.5,- transformers-compat >= 0.3 && < 0.8, utf8-string >= 0.3.4 && < 1.1,- xhtml,+ xhtml < 3000.4, zlib hs-source-dirs: src@@ -116,7 +128,7 @@ -- available 18 months ago. In order to avoid people spending time -- keeping the build working for older versions, we tell Cabal that -- it shouldn't allow builds with them.- if impl(ghc < 7.0)+ if impl(ghc < 8.0) buildable: False Test-Suite happstack-server-tests
src/Happstack/Server/Cookie.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-} -- | Functions for creating, adding, and expiring cookies. To lookup cookie values see "Happstack.Server.RqData". module Happstack.Server.Cookie ( Cookie(..)@@ -19,7 +19,7 @@ -- | Add the 'Cookie' to 'Response'. -- -- example--- +-- -- > main = simpleHTTP nullConf $ -- > do addCookie Session (mkCookie "name" "value") -- > ok $ "You now have a session cookie."@@ -33,7 +33,7 @@ addHeaderM a v = composeFilter $ \res-> addHeader a v res -- | Add the list 'Cookie' to the 'Response'.--- +-- -- see also: 'addCookie' addCookies :: (MonadIO m, FilterMonad Response m) => [(CookieLife, Cookie)] -> m () addCookies = mapM_ (uncurry addCookie)@@ -44,5 +44,5 @@ -- > do expireCookie "name" -- > ok $ "The cookie has been expired." -expireCookie :: (MonadIO m, FilterMonad Response m) => String -> m () +expireCookie :: (MonadIO m, FilterMonad Response m) => String -> m () expireCookie name = addCookie Expired (mkCookie name "")
src/Happstack/Server/Error.hs view
@@ -1,7 +1,7 @@ -- | Some useful functions if you want to wrap the 'ServerPartT' monad transformer around the 'ErrorT' monad transformer. e.g., @'ServerPartT' ('ErrorT' e m) a@. This allows you to use 'throwError' and 'catchError' inside your monad. module Happstack.Server.Error where -import Control.Monad.Error (Error, ErrorT(runErrorT))+import Control.Monad.Trans.Except (ExceptT, runExceptT) import Happstack.Server.Monads (ServerPartT) import Happstack.Server.Internal.Monads (WebT, UnWebT, withRequest, mkWebT, runServerPartT, ununWebT) import Happstack.Server.Response (ok, toResponse)@@ -22,10 +22,10 @@ -- see also: 'simpleErrorHandler' spUnwrapErrorT:: Monad m => (e -> ServerPartT m a) -> Request- -> UnWebT (ErrorT e m) a+ -> UnWebT (ExceptT e m) a -> UnWebT m a spUnwrapErrorT handler rq = \x -> do- err <- runErrorT x+ err <- runExceptT x case err of Left e -> ununWebT $ runServerPartT (handler e) rq Right a -> return a@@ -48,9 +48,9 @@ -- function. -- -- DEPRECATED: use 'spUnwrapErrorT' instead.-errorHandlerSP :: (Monad m, Error e) => (Request -> e -> WebT m a) -> ServerPartT (ErrorT e m) a -> ServerPartT m a+errorHandlerSP :: (Monad m) => (Request -> e -> WebT m a) -> ServerPartT (ExceptT e m) a -> ServerPartT m a errorHandlerSP handler sps = withRequest $ \req -> mkWebT $ do- eer <- runErrorT $ ununWebT $ runServerPartT sps req+ eer <- runExceptT $ ununWebT $ runServerPartT sps req case eer of Left err -> ununWebT (handler req err) Right res -> return res
src/Happstack/Server/FileServe/BuildingBlocks.hs view
@@ -59,11 +59,13 @@ import Control.Monad.Trans (MonadIO(liftIO)) import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Char8 as S-import Data.Data (Data, Typeable)+import Data.Char (toLower)+import Data.Data (Data) import Data.List (sort) import Data.Maybe (fromMaybe) import Data.Map (Map) import qualified Data.Map as Map+import Data.Time (UTCTime, formatTime, defaultTimeLocale) import Filesystem.Path.CurrentOS (commonPrefix, encodeString, decodeString, collapse, append) import Happstack.Server.Monads (ServerMonad(askRq), FilterMonad, WebMonad) import Happstack.Server.Response (ToMessage(toResponse), ifModifiedSince, forbidden, ok, seeOther)@@ -76,13 +78,6 @@ import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A -#if MIN_VERSION_time(1,5,0)-import Data.Time (UTCTime, formatTime, defaultTimeLocale)-#else-import System.Locale (defaultTimeLocale)-import Data.Time (UTCTime, formatTime)-#endif- -- * Mime-Type / Content-Type -- |a 'Map' from file extensions to content-types@@ -102,7 +97,7 @@ guessContentType mimeMap filepath = case getExt filepath of "" -> Nothing- ext -> Map.lookup ext mimeMap+ ext -> Map.lookup (map toLower ext) mimeMap -- FIXME? @foldCase@ would be more proper than @map toLower@ but would add a dependency. But are those edge cases ever going to be relevant here? -- | try to guess the content-type of a file based on its extension --@@ -127,7 +122,7 @@ -- | a list of common index files. Specifically: @index.html@, @index.xml@, @index.gif@ ----- Typically used as an argument to 'serveDiretory'.+-- Typically used as an argumebnt to 'serveDiretory'. defaultIxFiles :: [FilePath] defaultIxFiles= ["index.html","index.xml","index.gif"] @@ -136,6 +131,8 @@ fileNotFound fp = return $ result 404 $ "File not found " ++ fp -- | Similar to 'takeExtension' but does not include the extension separator char+--+-- NOTE: this does not perform case folding. So @example.jpg@ will return @.jpg@ and @example.JPG@ will return @.JPG@. getExt :: FilePath -> String getExt fp = drop 1 $ takeExtension fp @@ -529,7 +526,7 @@ listing <- renderFn localPath $ filter (/= ".") (sort c) ok $ toResponse $ listing -data EntryKind = File | Directory | UnknownKind deriving (Eq, Ord, Read, Show, Data, Typeable, Enum)+data EntryKind = File | Directory | UnknownKind deriving (Eq, Ord, Read, Show, Data, Enum) -- | a function to generate an HTML page showing the contents of a directory on the disk --@@ -631,7 +628,7 @@ -- | see 'serveDirectory' data Browsing = EnableBrowsing | DisableBrowsing- deriving (Eq, Enum, Ord, Read, Show, Data, Typeable)+ deriving (Eq, Enum, Ord, Read, Show, Data) -- | Serve files and directories from a directory and its subdirectories using 'sendFile'. --
src/Happstack/Server/Internal/Clock.hs view
@@ -9,19 +9,12 @@ import Control.Concurrent import Control.Monad+import qualified Data.ByteString.Char8 as B import Data.IORef import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime)-import System.IO.Unsafe--#if MIN_VERSION_time(1,5,0) import Data.Time.Format (formatTime, defaultTimeLocale)-#else-import Data.Time.Format (formatTime)-import System.Locale (defaultTimeLocale)-#endif--import qualified Data.ByteString.Char8 as B+import System.IO.Unsafe data DateCache = DateCache { cachedPOSIXTime :: !(IORef POSIXTime)
src/Happstack/Server/Internal/Cookie.hs view
@@ -21,21 +21,18 @@ import Control.Monad.Fail (MonadFail) import qualified Data.ByteString.Char8 as C import Data.Char (chr, toLower)-import Data.Data (Data, Typeable)+import Data.Data (Data) import Data.List ((\\), intersperse) import Data.Time.Clock (UTCTime, addUTCTime, diffUTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Data.Time.Format (formatTime, defaultTimeLocale) import Happstack.Server.Internal.Clock (getApproximateUTCTime) import Network.URI (escapeURIString) import Text.ParserCombinators.Parsec hiding (token) -#if MIN_VERSION_time(1,5,0)-import Data.Time.Format (formatTime, defaultTimeLocale)-#else-import Data.Time.Format (formatTime)-import System.Locale (defaultTimeLocale)-#endif ++ -- | a type for HTTP cookies. Usually created using 'mkCookie'. data Cookie = Cookie { cookieVersion :: String@@ -46,7 +43,8 @@ , secure :: Bool , httpOnly :: Bool , sameSite :: SameSite- } deriving(Show,Eq,Read,Typeable,Data)+ , partitioned :: Bool+ } deriving (Show, Eq, Read, Data) -- | Specify the lifetime of a cookie. --@@ -60,7 +58,7 @@ | MaxAge Int -- ^ life time of cookie in seconds | Expires UTCTime -- ^ cookie expiration date | Expired -- ^ cookie already expired- deriving (Eq, Ord, Read, Show, Typeable)+ deriving (Eq, Ord, Read, Show) -- | Options for specifying third party cookie behaviour. --@@ -77,7 +75,7 @@ -- secure. | SameSiteNoValue -- ^ The default; used if you do not wish a SameSite attribute present at all.- deriving (Eq, Ord, Typeable, Data, Show, Read)+ deriving (Eq, Ord, Data, Show, Read) displaySameSite :: SameSite -> String displaySameSite ss =@@ -102,13 +100,13 @@ -- | Creates a cookie with a default version of 1, empty domain, a -- path of "/", secure == False, httpOnly == False and--- sameSite == SameSiteNoValue+-- sameSite == SameSiteNoValue and partitioned = False -- -- see also: 'addCookie' mkCookie :: String -- ^ cookie name -> String -- ^ cookie value -> Cookie-mkCookie key val = Cookie "1" "/" "" key val False False SameSiteNoValue+mkCookie key val = Cookie "1" "/" "" key val False False SameSiteNoValue False -- | Set a Cookie in the Result. -- The values are escaped as per RFC 2109, but some browsers may@@ -147,6 +145,7 @@ ++ (if httpOnly cookie then ["HttpOnly"] else []) ++ (if sameSite cookie /= SameSiteNoValue then [displaySameSite . sameSite $ cookie] else [])+ ++ (if partitioned cookie then ["Partitioned"] else []) -- | Not an supported api. Takes a cookie header and returns -- either a String error message or an array of parsed cookies@@ -170,7 +169,7 @@ val<-value path<-option "" $ try (cookieSep >> cookie_path) domain<-option "" $ try (cookieSep >> cookie_domain)- return $ Cookie ver path domain (low name) val False False SameSiteNoValue+ return $ Cookie ver path domain (low name) val False False SameSiteNoValue False cookie_version = cookie_special "$Version" cookie_path = cookie_special "$Path" cookie_domain = cookie_special "$Domain"
src/Happstack/Server/Internal/Listen.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-} module Happstack.Server.Internal.Listen(listen, listen',listenOn,listenOnIPv4) where +import Data.Maybe (isNothing) import Happstack.Server.Internal.Types (Conf(..), Request, Response) import Happstack.Server.Internal.Handler (request) import Happstack.Server.Internal.Socket (acceptLite)@@ -118,7 +119,7 @@ infi :: IO () infi = loop `catchSome` pe >> infi - infi `finally` (Socket.close s >> forceTimeoutAll tm)+ infi `finally` (Socket.close s >> when (isNothing $ threadGroup conf) (forceTimeoutAll tm)) {-- #ifndef mingw32_HOST_OS
src/Happstack/Server/Internal/LogFormat.hs view
@@ -4,12 +4,7 @@ , formatRequestCombined ) where -#if MIN_VERSION_time(1,5,0) import Data.Time.Format (FormatTime(..), formatTime, defaultTimeLocale)-#else-import Data.Time.Format (FormatTime(..), formatTime)-import System.Locale (defaultTimeLocale)-#endif -- | Format the time as describe in the Apache combined log format. -- http://httpd.apache.org/docs/2.2/logs.html#combined
src/Happstack/Server/Internal/Monads.hs view
@@ -12,9 +12,11 @@ ) import Control.Monad.Base ( MonadBase, liftBase ) import Control.Monad.Catch ( MonadCatch(..), MonadThrow(..) )-import Control.Monad.Error ( ErrorT(ErrorT), runErrorT- , Error, MonadError, throwError- , catchError, mapErrorT+#if !MIN_VERSION_transformers(0,6,0)+import Control.Monad.Trans.Error ( ErrorT, Error, mapErrorT )+#endif+import Control.Monad.Except ( MonadError, throwError+ , catchError ) #if MIN_VERSION_base(4,9,0) import Control.Monad.Fail (MonadFail)@@ -26,7 +28,7 @@ import qualified Control.Monad.RWS.Lazy as Lazy ( RWST, mapRWST ) import qualified Control.Monad.RWS.Strict as Strict ( RWST, mapRWST ) -import Control.Monad.Trans.Except ( ExceptT, mapExceptT )+import Control.Monad.Trans.Except ( ExceptT(ExceptT), mapExceptT, runExceptT ) import Control.Monad.State.Class ( MonadState, get, put ) import qualified Control.Monad.State.Lazy as Lazy ( StateT, mapStateT ) import qualified Control.Monad.State.Strict as Strict ( StateT, mapStateT )@@ -93,7 +95,6 @@ liftIO = ServerPartT . liftIO {-# INLINE liftIO #-} -#if MIN_VERSION_monad_control(1,0,0) instance MonadTransControl ServerPartT where type StT ServerPartT a = StT WebT (StT (ReaderT Request) a) liftWith f = ServerPartT $ liftWith $ \runReader ->@@ -105,20 +106,7 @@ type StM (ServerPartT m) a = ComposeSt ServerPartT m a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM-#else-instance MonadTransControl ServerPartT where- newtype StT ServerPartT a = StSP {unStSP :: StT WebT (StT (ReaderT Request) a)}- liftWith f = ServerPartT $ liftWith $ \runReader ->- liftWith $ \runWeb ->- f $ liftM StSP . runWeb . runReader . unServerPartT- restoreT = ServerPartT . restoreT . restoreT . liftM unStSP -instance MonadBaseControl b m => MonadBaseControl b (ServerPartT m) where- newtype StM (ServerPartT m) a = StMSP {unStMSP :: ComposeSt ServerPartT m a}- liftBaseWith = defaultLiftBaseWith StMSP- restoreM = defaultRestoreM unStMSP-#endif- -- | Particularly useful when combined with 'runWebT' to produce -- a @m ('Maybe' 'Response')@ from a 'Request'. runServerPartT :: ServerPartT m a -> Request -> WebT m a@@ -342,7 +330,6 @@ liftIO = FilterT . liftIO {-# INLINE liftIO #-} -#if MIN_VERSION_monad_control(1,0,0) instance MonadTransControl (FilterT a) where type StT (FilterT a) b = StT (Lazy.WriterT (FilterFun a)) b liftWith f = FilterT $ liftWith $ \run -> f $ run . unFilterT@@ -352,18 +339,7 @@ type StM (FilterT a m) c = ComposeSt (FilterT a) m c liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM-#else-instance MonadTransControl (FilterT a) where- newtype StT (FilterT a) b = StFilter {unStFilter :: StT (Lazy.WriterT (FilterFun a)) b}- liftWith f = FilterT $ liftWith $ \run -> f $ liftM StFilter . run . unFilterT- restoreT = FilterT . restoreT . liftM unStFilter -instance MonadBaseControl b m => MonadBaseControl b (FilterT a m) where- newtype StM (FilterT a m) c = StMFilter {unStMFilter :: ComposeSt (FilterT a) m c}- liftBaseWith = defaultLiftBaseWith StMFilter- restoreM = defaultRestoreM unStMFilter-#endif- -- | A set of functions for manipulating filters. -- -- 'ServerPartT' implements 'FilterMonad' 'Response' so these methods@@ -397,7 +373,7 @@ getFilter = FilterT . listens unFilterFun . unFilterT -- | The basic 'Response' building object.-newtype WebT m a = WebT { unWebT :: ErrorT Response (FilterT (Response) (MaybeT m)) a }+newtype WebT m a = WebT { unWebT :: ExceptT Response (FilterT (Response) (MaybeT m)) a } deriving (Functor) instance MonadCatch m => MonadCatch (WebT m) where@@ -413,41 +389,23 @@ liftIO = WebT . liftIO {-# INLINE liftIO #-} -#if MIN_VERSION_monad_control(1,0,0) instance MonadTransControl WebT where type StT WebT a = StT MaybeT (StT (FilterT Response)- (StT (ErrorT Response) a))+ (StT (ExceptT Response) a)) liftWith f = WebT $ liftWith $ \runError -> liftWith $ \runFilter -> liftWith $ \runMaybe -> f $ runMaybe . runFilter .- runError . unWebT+ runExceptT . unWebT restoreT = WebT . restoreT . restoreT . restoreT instance MonadBaseControl b m => MonadBaseControl b (WebT m) where type StM (WebT m) a = ComposeSt WebT m a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM-#else-instance MonadTransControl WebT where- newtype StT WebT a = StWeb {unStWeb :: StT MaybeT- (StT (FilterT Response)- (StT (ErrorT Response) a))}- liftWith f = WebT $ liftWith $ \runError ->- liftWith $ \runFilter ->- liftWith $ \runMaybe ->- f $ liftM StWeb . runMaybe .- runFilter .- runError . unWebT- restoreT = WebT . restoreT . restoreT . restoreT . liftM unStWeb -instance MonadBaseControl b m => MonadBaseControl b (WebT m) where- newtype StM (WebT m) a = StMWeb {unStMWeb :: ComposeSt WebT m a}- liftBaseWith = defaultLiftBaseWith StMWeb- restoreM = defaultRestoreM unStMWeb-#endif -- | 'UnWebT' is almost exclusively used with 'mapServerPartT'. If you -- are not using 'mapServerPartT' then you do not need to wrap your -- head around this type. If you are -- the type is not as complex as@@ -555,13 +513,13 @@ -- is exactly the semantics expected from objects that take lists -- of 'ServerPartT'. mzero = WebT $ lift $ lift $ mzero- mplus x y = WebT $ ErrorT $ FilterT $ (lower x) `mplus` (lower y)- where lower = (unFilterT . runErrorT . unWebT)+ mplus x y = WebT $ ExceptT $ FilterT $ (lower x) `mplus` (lower y)+ where lower = (unFilterT . runExceptT . unWebT) instance (Monad m) => FilterMonad Response (WebT m) where setFilter f = WebT $ lift $ setFilter $ f composeFilter f = WebT . lift . composeFilter $ f- getFilter m = WebT $ ErrorT $ liftM lft $ getFilter (runErrorT $ unWebT m)+ getFilter m = WebT $ ExceptT $ liftM lft $ getFilter (runExceptT $ unWebT m) where lft (Left r, _) = Left r lft (Right a, f) = Right (a, f)@@ -576,11 +534,11 @@ -- | For when you really need to unpack a 'WebT' entirely (and not -- just unwrap the first layer with 'unWebT'). ununWebT :: WebT m a -> UnWebT m a-ununWebT = runMaybeT . Lazy.runWriterT . unFilterT . runErrorT . unWebT+ununWebT = runMaybeT . Lazy.runWriterT . unFilterT . runExceptT . unWebT -- | For wrapping a 'WebT' back up. @'mkWebT' . 'ununWebT' = 'id'@ mkWebT :: UnWebT m a -> WebT m a-mkWebT = WebT . ErrorT . FilterT . Lazy.WriterT . MaybeT+mkWebT = WebT . ExceptT . FilterT . Lazy.WriterT . MaybeT -- | See 'mapServerPartT' for a discussion of this function. mapWebT :: (UnWebT m a -> UnWebT n b)@@ -798,6 +756,7 @@ -- ErrorT +#if !MIN_VERSION_transformers(0,6,0) instance (Error e, ServerMonad m) => ServerMonad (ErrorT e m) where askRq = lift askRq localRq f = mapErrorT $ localRq f@@ -814,6 +773,7 @@ instance (Error e, WebMonad a m) => WebMonad a (ErrorT e m) where finishWith = lift . finishWith+#endif -- ExceptT
src/Happstack/Server/Internal/Types.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable, FlexibleInstances, RankNTypes #-}+{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable, FlexibleInstances, RankNTypes, CPP #-} module Happstack.Server.Internal.Types (Request(..), Response(..), RqBody(..), Input(..), HeaderPair(..),@@ -21,7 +21,9 @@ import Control.Exception (Exception, SomeException)-import Control.Monad.Error (Error(strMsg))+#if !MIN_VERSION_transformers(0,6,0)+import Control.Monad.Trans.Error (Error(strMsg))+#endif import Control.Monad.Fail (MonadFail) import Control.Monad.Trans (MonadIO(liftIO)) import qualified Control.Concurrent.Thread.Group as TG@@ -30,7 +32,6 @@ import Data.Data (Data) import Data.String (fromString) import Data.Time.Format (FormatTime(..))-import Data.Typeable(Typeable) import qualified Data.ByteString.Char8 as P import Data.ByteString.Char8 (ByteString,pack) import qualified Data.ByteString.Lazy.Char8 as L@@ -115,7 +116,7 @@ , validator :: Maybe (Response -> IO Response) -- ^ a function to validate the output on-the-fly , logAccess :: forall t. FormatTime t => Maybe (LogAccess t) -- ^ function to log access requests (see also: 'logMAccess') , timeout :: Int -- ^ number of seconds to wait before killing an inactive thread- , threadGroup :: Maybe TG.ThreadGroup -- ^ ThreadGroup for registering spawned threads for handling requests+ , threadGroup :: Maybe TG.ThreadGroup -- ^ ThreadGroup for registering spawned threads for handling requests. } -- | Default configuration contains no validator and the port is set to 8000@@ -137,7 +138,7 @@ -- | HTTP request method data Method = GET | HEAD | POST | PUT | DELETE | TRACE | OPTIONS | CONNECT | PATCH | EXTENSION ByteString- deriving (Show,Read,Eq,Ord,Typeable,Data)+ deriving (Show, Read, Eq, Ord, Data) -- | Does the method support a message body? --@@ -177,7 +178,7 @@ -- | Result flags data RsFlags = RsFlags { rsfLength :: Length- } deriving (Show,Read,Typeable)+ } deriving (Show, Read) -- | Default RsFlags: automatically use @Transfer-Encoding: Chunked@. nullRsFlags :: RsFlags@@ -202,7 +203,7 @@ { inputValue :: Either FilePath L.ByteString , inputFilename :: Maybe FilePath , inputContentType :: ContentType- } deriving (Show, Read, Typeable)+ } deriving (Show, Read) -- | hostname & port type Host = (String, Int) -- ^ (hostname, port)@@ -223,7 +224,6 @@ , sfOffset :: Integer -- ^ offset to start at , sfCount :: Integer -- ^ number of bytes to send }- deriving (Typeable) instance Show Response where showsPrec _ res@Response{} =@@ -246,11 +246,13 @@ showRsValidator :: Maybe (Response -> IO Response) -> String showRsValidator = maybe "Nothing" (const "Just <function>") +#if !MIN_VERSION_transformers(0,6,0) -- what should the status code be ? instance Error Response where strMsg str = setHeader "Content-Type" "text/plain; charset=UTF-8" $ result 500 str+#endif -- | an HTTP request data Request = Request@@ -266,7 +268,7 @@ , rqHeaders :: Headers -- ^ the HTTP request headers , rqBody :: MVar RqBody -- ^ the raw, undecoded request body , rqPeer :: Host -- ^ (hostname, port) of the client making the request- } deriving (Typeable)+ } instance Show Request where showsPrec _ rq =@@ -325,7 +327,7 @@ headers = id -- | The body of an HTTP 'Request'-newtype RqBody = Body { unBody :: L.ByteString } deriving (Read,Show,Typeable)+newtype RqBody = Body { unBody :: L.ByteString } deriving (Read, Show) -- | Sets the Response status code to the provided Int and lifts the computation -- into a Monad.@@ -527,7 +529,6 @@ -- | Escape from the HTTP world and get direct access to the underlying 'TimeoutIO' functions data EscapeHTTP = EscapeHTTP (TimeoutIO -> IO ())- deriving (Typeable) instance Exception EscapeHTTP
src/Happstack/Server/Monads.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts, CPP #-} -- | This module provides four classes and some related functions -- which provide 'ServerPartT' with much of its web-centric behavior. --@@ -41,7 +41,9 @@ import Control.Applicative (Alternative, Applicative) import Control.Monad (MonadPlus(mzero))-import Control.Monad.Error (Error, ErrorT)+#if !MIN_VERSION_transformers(0,6,0)+import Control.Monad.Trans.Error (Error, ErrorT)+#endif import Control.Monad.Trans (MonadIO(..),MonadTrans(lift)) import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Reader (ReaderT)@@ -71,7 +73,9 @@ instance (Happstack m, Monoid w) => Happstack (Strict.WriterT w m) instance (Happstack m, Monoid w) => Happstack (Lazy.RWST r w s m) instance (Happstack m, Monoid w) => Happstack (Strict.RWST r w s m)+#if !MIN_VERSION_transformers(0,6,0) instance (Happstack m, Error e) => Happstack (ErrorT e m)+#endif instance (Happstack m, Monoid e) => Happstack (ExceptT e m) -- | Get a header out of the request.
src/Happstack/Server/Response.hs view
@@ -26,6 +26,9 @@ , ifModifiedSince ) where +#if MIN_VERSION_xhtml(3000,3,0)+import qualified Data.ByteString.Builder as L+#endif import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Lazy.UTF8 as LU (fromString)@@ -34,6 +37,7 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT+import Data.Time (UTCTime, formatTime, defaultTimeLocale) import Happstack.Server.Internal.Monads (FilterMonad(composeFilter)) import Happstack.Server.Internal.Types import Happstack.Server.Types (Response(..), Request(..), nullRsFlags, getHeader, noContentLength, redirect, result, setHeader, setHeaderBS)@@ -43,12 +47,6 @@ import Text.Html (Html, renderHtml) import qualified Text.XHtml as XHtml (Html, renderHtml) -#if MIN_VERSION_time(1,5,0)-import Data.Time (UTCTime, formatTime, defaultTimeLocale)-#else-import Data.Time (UTCTime, formatTime)-import System.Locale (defaultTimeLocale)-#endif -- | A low-level function to build a 'Response' from a content-type -- and a 'ByteString'.@@ -140,8 +138,11 @@ instance ToMessage XHtml.Html where toContentType _ = B.pack "text/html; charset=UTF-8"+#if MIN_VERSION_xhtml(3000,3,0)+ toMessage = L.toLazyByteString . XHtml.renderHtml+#else toMessage = LU.fromString . XHtml.renderHtml-+#endif instance ToMessage Blaze.Html where toContentType _ = B.pack "text/html; charset=UTF-8" toMessage = Blaze.renderHtml
src/Happstack/Server/Routing.hs view
@@ -109,7 +109,7 @@ -- -- > handler :: ServerPart Response -- > handler =--- > do methodOnly [GET, HEAD]+-- > do method [GET, HEAD] -- > ... method :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m () method meth = guardRq $ \rq -> matchMethod meth (rqMethod rq)
src/Happstack/Server/RqData.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE CPP, DeriveDataTypeable, GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, StandaloneDeriving, UndecidableInstances #-} -- | Functions for extracting values from the query string, form data, cookies, etc. -- -- For in-depth documentation see the following section of the Happstack Crash Course:@@ -59,7 +59,7 @@ ) where import Control.Applicative (Applicative((<*>), pure), Alternative((<|>), empty), WrappedMonad(WrapMonad, unwrapMonad))-import Control.Monad (MonadPlus(mzero))+import Control.Monad (MonadPlus(mzero, mplus)) import Control.Monad.Reader (ReaderT(ReaderT, runReaderT), MonadReader(ask, local), mapReaderT) import qualified Control.Monad.State.Lazy as Lazy (StateT, mapStateT) import qualified Control.Monad.State.Strict as Strict (StateT, mapStateT)@@ -67,7 +67,10 @@ import qualified Control.Monad.Writer.Strict as Strict (WriterT, mapWriterT) import qualified Control.Monad.RWS.Lazy as Lazy (RWST, mapRWST) import qualified Control.Monad.RWS.Strict as Strict (RWST, mapRWST)-import Control.Monad.Error (Error(noMsg, strMsg), ErrorT, mapErrorT)+#if !MIN_VERSION_transformers(0,6,0)+import qualified Control.Monad.Trans.Error as DeprecatedError+#endif+import Control.Monad.Except (throwError) import Control.Monad.Trans (MonadIO(..), lift) import Control.Monad.Trans.Except (ExceptT, mapExceptT) import qualified Data.ByteString.Char8 as P@@ -75,7 +78,7 @@ import qualified Data.ByteString.Lazy.UTF8 as LU import Data.Char (toLower) import Data.Either (partitionEithers)-import Data.Generics (Data, Typeable)+import Data.Generics (Data) import Data.Maybe (fromJust) import Data.Monoid (Monoid(mempty, mappend, mconcat)) import qualified Data.Semigroup as SG@@ -90,18 +93,36 @@ import Network.URI (unEscapeString) newtype ReaderError r e a = ReaderError { unReaderError :: ReaderT r (Either e) a }- deriving (Functor, Monad, MonadPlus)+ deriving (Functor, Monad) -instance (Error e, Monoid e) => MonadReader r (ReaderError r e) where+#if MIN_VERSION_transformers(0,6,0)+deriving instance (Monoid e, MonadPlus (Either e)) => MonadPlus (ReaderError r e)+#else+deriving instance (Monoid e, DeprecatedError.Error e, MonadPlus (Either e)) => MonadPlus (ReaderError r e)+#endif++#if MIN_VERSION_transformers(0,6,0)+instance (Monoid e) => MonadReader r (ReaderError r e) where+#else+instance (DeprecatedError.Error e, Monoid e) => MonadReader r (ReaderError r e) where+#endif ask = ReaderError ask local f m = ReaderError $ local f (unReaderError m) -instance (Monoid e, Error e) => Applicative (ReaderError r e) where+#if MIN_VERSION_transformers(0,6,0)+instance (Monoid e) => Applicative (ReaderError r e) where+#else+instance (Monoid e, DeprecatedError.Error e) => Applicative (ReaderError r e) where+#endif pure = return (ReaderError (ReaderT f)) <*> (ReaderError (ReaderT a)) = ReaderError $ ReaderT $ \env -> (f env) `apEither` (a env) -instance (Monoid e, Error e) => Alternative (ReaderError r e) where+#if MIN_VERSION_transformers(0,6,0)+instance (MonadPlus (Either e), Monoid e) => Alternative (ReaderError r e) where+#else+instance (Monoid e, DeprecatedError.Error e) => Alternative (ReaderError r e) where+#endif empty = unwrapMonad empty f <|> g = unwrapMonad $ (WrapMonad f) <|> (WrapMonad g) @@ -113,7 +134,7 @@ -- | a list of errors newtype Errors a = Errors { unErrors :: [a] }- deriving (Eq, Ord, Show, Read, Data, Typeable)+ deriving (Eq, Ord, Show, Read, Data) instance SG.Semigroup (Errors a) where (Errors x) <> (Errors y) = Errors (x ++ y)@@ -123,10 +144,27 @@ mappend = (SG.<>) mconcat errs = Errors $ concatMap unErrors errs -instance Error (Errors String) where+#if MIN_VERSION_transformers(0,6,0)+instance (Alternative (Either (Errors a))) => MonadPlus (Either (Errors a)) where+ mzero = Left (Errors [])+ (Left _) `mplus` n = n+ m `mplus` _ = m++instance Alternative (Either (Errors a)) where+ empty = Left (Errors [])+ (Left _) <|> n = n+ m <|> _ = m+#endif++#if !MIN_VERSION_transformers(0,6,0)+instance DeprecatedError.Error (Errors String) where noMsg = Errors [] strMsg str = Errors [str]+#endif +strMsg :: a -> Errors a+strMsg errMsg = Errors [errMsg]+ {- commented out to avoid 'Defined but not used' warning. readerError :: (Monoid e, Error e) => e -> ReaderError r e b readerError e = mapReaderErrorT ((Left e) `apEither`) (return ())@@ -204,10 +242,12 @@ localRqEnv f = Strict.mapRWST (localRqEnv f) rqDataError e = lift (rqDataError e) -instance (Monad m, Error e, HasRqData m) => HasRqData (ErrorT e m) where+#if !MIN_VERSION_transformers(0,6,0)+instance (Monad m, DeprecatedError.Error e, HasRqData m) => HasRqData (DeprecatedError.ErrorT e m) where askRqEnv = lift askRqEnv- localRqEnv f = mapErrorT (localRqEnv f)+ localRqEnv f = DeprecatedError.mapErrorT (localRqEnv f) rqDataError e = lift (rqDataError e)+#endif instance (Monad m, HasRqData m) => HasRqData (ExceptT e m) where askRqEnv = lift askRqEnv@@ -264,7 +304,6 @@ (Just a) -> Right a _ -> Left $ "readRq failed while parsing key: " ++ key ++ " which has the value: " ++ val - -- | convert or validate a value -- -- This is similar to 'fmap' except that the function can fail by@@ -454,7 +493,7 @@ Nothing -> rqDataError $ strMsg $ "lookCookie: cookie not found: " ++ name Just c -> return c{cookieValue = f c} where- f = unEscapeString . cookieValue + f = unEscapeString . cookieValue -- | gets the named cookie as a string lookCookieValue :: (Functor m, Monad m, HasRqData m) => String -> m String
src/Happstack/Server/SURI.hs view
@@ -23,7 +23,7 @@ import Control.Arrow (first) import Data.Char (chr, digitToInt, isHexDigit) import Data.Maybe (fromJust, isJust)-import Data.Generics (Data, Typeable)+import Data.Generics (Data) import qualified Data.Text as Text import qualified Data.Text.Lazy as LazyText import qualified Network.URI as URI@@ -74,7 +74,7 @@ isAbs :: SURI -> Bool isAbs = not . null . URI.uriScheme . suri -newtype SURI = SURI {suri::URI.URI} deriving (Eq,Data,Typeable)+newtype SURI = SURI {suri::URI.URI} deriving (Eq,Data) instance Show SURI where showsPrec d (SURI uri) = showsPrec d $ show uri instance Read SURI where
src/Happstack/Server/SimpleHTTP.hs view
@@ -30,9 +30,9 @@ -- > import Happstack.Server -- > main = simpleHTTP nullConf $ ok "Hello World!" ----- By default the server will listen on port 8000. Run the app and point your browser at: <http://localhost:8000/>+-- By default the server will listen on port 8000. Run the app and point your browser at: <http:\/\/localhost:8000\/> ----- For FastCGI support see: <http://hackage.haskell.org/package/happstack-fastcgi>+-- For FastCGI support see: <http:\/\/hackage.haskell.org\/package\/happstack-fastcgi> ----------------------------------------------------------------------------- module Happstack.Server.SimpleHTTP ( -- * SimpleHTTP@@ -44,6 +44,7 @@ , bindPort , bindIPv4 , parseConfig+ , runWebT , waitForTermination -- * Re-exported modules -- ** Basic ServerMonad functionality
tests/Happstack/Server/Tests.hs view
@@ -10,9 +10,11 @@ import Data.ByteString.Lazy.Char8 (pack, unpack) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as L+import Data.List (intercalate) import qualified Data.Map as Map import Happstack.Server ( Request(..), Method(..), Response(..), ServerPart, Headers, RqBody(Body), HttpVersion(..)- , ToMessage(..), HeaderPair(..), ok, dir, simpleHTTP'', composeFilter, noContentLength, matchMethod)+ , ToMessage(..), HeaderPair(..), ok, dir, simpleHTTP'', composeFilter, noContentLength, matchMethod+ , look, getDataFn) import Happstack.Server.FileServe.BuildingBlocks (sendFileResponse) import Happstack.Server.Cookie import Happstack.Server.Internal.Compression@@ -34,6 +36,7 @@ , matchMethodTest , cookieHeaderOrderTest , pContentDispositionFilename+ , applicativeTest ] cookieParserTest :: Test@@ -41,24 +44,24 @@ "cookieParserTest" ~: [parseCookies "$Version=1;Cookie1=value1;$Path=\"/testpath\";$Domain=example.com;cookie2=value2" @?= (Right [- Cookie "1" "/testpath" "example.com" "cookie1" "value1" False False SameSiteNoValue- , Cookie "1" "" "" "cookie2" "value2" False False SameSiteNoValue+ Cookie "1" "/testpath" "example.com" "cookie1" "value1" False False SameSiteNoValue False+ , Cookie "1" "" "" "cookie2" "value2" False False SameSiteNoValue False ]) ,parseCookies " \t $Version = \"1\" ; cookie1 = \"randomcrap!@#%^&*()-_+={}[]:;'<>,.?/\\|\" , $Path=/ " @?= (Right [- Cookie "1" "/" "" "cookie1" "randomcrap!@#%^&*()-_+={}[]:;'<>,.?/|" False False SameSiteNoValue+ Cookie "1" "/" "" "cookie1" "randomcrap!@#%^&*()-_+={}[]:;'<>,.?/|" False False SameSiteNoValue False ]) ,parseCookies " cookie1 = value1 " @?= (Right [- Cookie "" "" "" "cookie1" "value1" False False SameSiteNoValue+ Cookie "" "" "" "cookie1" "value1" False False SameSiteNoValue False ]) ,parseCookies " $Version=\"1\";buggygooglecookie = valuewith=whereitshouldnotbe " @?= (Right [- Cookie "1" "" "" "buggygooglecookie" "valuewith=whereitshouldnotbe" False False SameSiteNoValue+ Cookie "1" "" "" "buggygooglecookie" "valuewith=whereitshouldnotbe" False False SameSiteNoValue False ]) , parseCookies "foo=\"\\\"bar\\\"\"" @?= (Right [- Cookie "" "" "" "foo" "\"bar\"" False False SameSiteNoValue+ Cookie "" "" "" "foo" "\"bar\"" False False SameSiteNoValue False ]) ] @@ -247,3 +250,13 @@ do let doesNotWorkWithOldParserButWithNew = "form-data; filename=\"file.pdf\"; name=\"file\"" :: String c <- parseContentDisposition doesNotWorkWithOldParserButWithNew assertEqual "parseContentDisposition" c (ContentDisposition "form-data" [("filename","file.pdf"),("name","file")])++applicativeTest :: Test+applicativeTest =+ "applicativeTest" ~:+ do req <- mkRequest GET "/response" [] mempty L.empty+ res <- flip simpleHTTP'' req $ do+ Left errors <- getDataFn $ (++) <$> look "a" <*> look "b"+ pure $ intercalate "," errors+ let ref = "Parameter not found: a,Parameter not found: b"+ assertEqual "getDataFn/ReaderError doesn't short-circuit" ref (unpack (rsBody res))