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.5.0.1 +Version: 7.5.0.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 License: BSD3 @@ -11,7 +11,7 @@ Build-Type: Simple Cabal-Version: >= 1.10 Extra-Source-Files: tests/Happstack/Server/Tests.hs README.md -tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2, GHC==8.0.1 +tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2, GHC==8.0.1, GHC==8.2.2 source-repository head type: git @@ -90,17 +90,18 @@ old-locale, parsec < 4, process, + semigroups >= 0.16, sendfile >= 0.7.1 && < 0.8, system-filepath >= 0.3.1, syb, text >= 0.10 && < 1.3, - template-haskell < 2.13, + template-haskell < 2.14, time, time-compat, threads >= 0.5, transformers >= 0.1.3 && < 0.6, transformers-base >= 0.4 && < 0.5, - transformers-compat >= 0.3 && < 0.6, + transformers-compat >= 0.3 && < 0.7, utf8-string >= 0.3.4 && < 1.1, xhtml, zlib @@ -115,10 +116,11 @@ Build-Depends: unix cpp-options: -DUNIX - Extensions: DeriveDataTypeable, MultiParamTypeClasses, - TypeFamilies, FlexibleContexts, OverlappingInstances, - FlexibleInstances, UndecidableInstances, ScopedTypeVariables, - TypeSynonymInstances, PatternGuards + Default-Extensions: OverlappingInstances + Other-Extensions: DeriveDataTypeable, MultiParamTypeClasses, + TypeFamilies, FlexibleContexts, + FlexibleInstances, UndecidableInstances, + ScopedTypeVariables, TypeSynonymInstances, PatternGuards CPP, ForeignFunctionInterface ghc-options: -Wall -fwarn-tabs -- The policy is to support GHC versions no older than the GHC stable @@ -133,10 +135,11 @@ Default-language: Haskell2010 Type: exitcode-stdio-1.0 Main-Is: Test.hs + Other-Modules: Happstack.Server.Tests GHC-Options: -threaded hs-source-dirs: tests Build-depends: HUnit, - base, + base >= 4 && < 5, bytestring, containers, happstack-server, 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, ScopedTypeVariables, Rank2Types #-} +{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, ScopedTypeVariables, Rank2Types #-} -- | Build your own file serving functions -- -- If the functions in "Happstack.Server.FileServe" do not quite do diff --git a/src/Happstack/Server/Internal/Clock.hs b/src/Happstack/Server/Internal/Clock.hs --- a/src/Happstack/Server/Internal/Clock.hs +++ b/src/Happstack/Server/Internal/Clock.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# OPTIONS -fno-cse #-} module Happstack.Server.Internal.Clock ( getApproximateTime diff --git a/src/Happstack/Server/Internal/Cookie.hs b/src/Happstack/Server/Internal/Cookie.hs --- a/src/Happstack/Server/Internal/Cookie.hs +++ b/src/Happstack/Server/Internal/Cookie.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP, DeriveDataTypeable #-} -- http://tools.ietf.org/html/rfc2109 module Happstack.Server.Internal.Cookie diff --git a/src/Happstack/Server/Internal/LogFormat.hs b/src/Happstack/Server/Internal/LogFormat.hs --- a/src/Happstack/Server/Internal/LogFormat.hs +++ b/src/Happstack/Server/Internal/LogFormat.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module Happstack.Server.Internal.LogFormat ( formatTimeCombined , formatRequestCombined diff --git a/src/Happstack/Server/Internal/Monads.hs b/src/Happstack/Server/Internal/Monads.hs --- a/src/Happstack/Server/Internal/Monads.hs +++ b/src/Happstack/Server/Internal/Monads.hs @@ -45,6 +45,7 @@ import Data.List (inits, isPrefixOf, stripPrefix, tails) import Data.Maybe (fromMaybe) import Data.Monoid (Monoid(mempty, mappend), Dual(..), Endo(..)) +import qualified Data.Semigroup as SG import qualified Paths_happstack_server as Cabal import qualified Data.Version as DV import Debug.Trace (trace) @@ -184,9 +185,12 @@ instance MonadTrans (ServerPartT) where lift m = withRequest (\_ -> lift m) +instance (Monad m, MonadPlus m) => SG.Semigroup (ServerPartT m a) where + (<>) = mplus + instance (Monad m, MonadPlus m) => Monoid (ServerPartT m a) where mempty = mzero - mappend = mplus + mappend = (SG.<>) instance (Monad m, Functor m) => Applicative (ServerPartT m) where pure = return @@ -282,12 +286,14 @@ data SetAppend a = Set a | Append a deriving (Eq, Show) -instance Monoid a => Monoid (SetAppend a) where - mempty = Append mempty +instance Monoid a => SG.Semigroup (SetAppend a) where + Set x <> Append y = Set (x `mappend` y) + Append x <> Append y = Append (x `mappend` y) + _ <> Set y = Set y - Set x `mappend` Append y = Set (x `mappend` y) - Append x `mappend` Append y = Append (x `mappend` y) - _ `mappend` Set y = Set y +instance Monoid a => Monoid (SetAppend a) where + mempty = Append mempty + mappend = (SG.<>) -- | Extract the value from a 'SetAppend'. -- Note that a 'SetAppend' is actually a @CoPointed@ from: @@ -547,9 +553,12 @@ lft (Left r, _) = Left r lft (Right a, f) = Right (a, f) +instance (Monad m, MonadPlus m) => SG.Semigroup (WebT m a) where + (<>) = mplus + instance (Monad m, MonadPlus m) => Monoid (WebT m a) where - mempty = mzero - mappend = mplus + mempty = mzero + mappend = (SG.<>) -- | For when you really need to unpack a 'WebT' entirely (and not -- just unwrap the first layer with 'unWebT'). diff --git a/src/Happstack/Server/Response.hs b/src/Happstack/Server/Response.hs --- a/src/Happstack/Server/Response.hs +++ b/src/Happstack/Server/Response.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, TypeSynonymInstances, ScopedTypeVariables #-} +{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, TypeSynonymInstances, ScopedTypeVariables #-} -- | Functions and classes related to generating a 'Response' and setting the response code. For detailed instruction see the Happstack Crash Course: module Happstack.Server.Response ( -- * Converting values to a 'Response' @@ -97,7 +97,7 @@ toContentType _ = B.pack "text/plain" toMessage :: a -> L.ByteString toMessage = error "Happstack.Server.SimpleHTTP.ToMessage.toMessage: Not defined" - toResponse:: a -> Response + toResponse :: a -> Response toResponse val = let bs = toMessage val res = Response 200 M.empty nullRsFlags bs Nothing diff --git a/src/Happstack/Server/RqData.hs b/src/Happstack/Server/RqData.hs --- a/src/Happstack/Server/RqData.hs +++ b/src/Happstack/Server/RqData.hs @@ -78,6 +78,7 @@ import Data.Generics (Data, Typeable) import Data.Maybe (fromJust) import Data.Monoid (Monoid(mempty, mappend, mconcat)) +import qualified Data.Semigroup as SG import Data.Text (Text) import qualified Data.Text.Lazy as LazyText import qualified Data.Text.Lazy.Encoding as LazyText @@ -113,9 +114,12 @@ newtype Errors a = Errors { unErrors :: [a] } deriving (Eq, Ord, Show, Read, Data, Typeable) +instance SG.Semigroup (Errors a) where + (Errors x) <> (Errors y) = Errors (x ++ y) + instance Monoid (Errors a) where mempty = Errors [] - (Errors x) `mappend` (Errors y) = Errors (x ++ y) + mappend = (SG.<>) mconcat errs = Errors $ concatMap unErrors errs instance Error (Errors String) where