Remove all conditional compilation for Yesod 1.4 release
Left in for GHC-bundled libraries (ghc, base, bytestring, binary)
This commit is contained in:
Michael Snoyman
parent
598e570913
commit
ccab062f2d
@ -1,4 +1,3 @@
|
||||
./yesod-routes
|
||||
./yesod-core
|
||||
./yesod-static
|
||||
./yesod-persistent
|
||||
|
||||
@ -161,7 +161,6 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
|
||||
-- Since 1.2.0
|
||||
maybeAuthId :: HandlerT master IO (Maybe (AuthId master))
|
||||
|
||||
#if MIN_VERSION_persistent(2, 0, 0)
|
||||
default maybeAuthId
|
||||
:: ( YesodAuth master
|
||||
, PersistEntityBackend val ~ YesodPersistBackend master
|
||||
@ -172,19 +171,6 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
|
||||
, Typeable val
|
||||
)
|
||||
=> HandlerT master IO (Maybe (AuthId master))
|
||||
#else
|
||||
default maybeAuthId
|
||||
:: ( YesodAuth master
|
||||
, PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val
|
||||
, b ~ YesodPersistBackend master
|
||||
, Key val ~ AuthId master
|
||||
, PersistStore (b (HandlerT master IO))
|
||||
, PersistEntity val
|
||||
, YesodPersist master
|
||||
, Typeable val
|
||||
)
|
||||
=> HandlerT master IO (Maybe (AuthId master))
|
||||
#endif
|
||||
maybeAuthId = defaultMaybeAuthId
|
||||
|
||||
-- | Called on login error for HTTP requests. By default, calls
|
||||
@ -206,7 +192,6 @@ credsKey = "_ID"
|
||||
-- 'maybeAuthIdRaw' for more information.
|
||||
--
|
||||
-- Since 1.1.2
|
||||
#if MIN_VERSION_persistent(2, 0, 0)
|
||||
defaultMaybeAuthId
|
||||
:: ( YesodAuth master
|
||||
, b ~ YesodPersistBackend master
|
||||
@ -217,18 +202,6 @@ defaultMaybeAuthId
|
||||
, YesodPersist master
|
||||
, Typeable val
|
||||
) => HandlerT master IO (Maybe (AuthId master))
|
||||
#else
|
||||
defaultMaybeAuthId
|
||||
:: ( YesodAuth master
|
||||
, PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val
|
||||
, b ~ YesodPersistBackend master
|
||||
, Key val ~ AuthId master
|
||||
, PersistStore (b (HandlerT master IO))
|
||||
, PersistEntity val
|
||||
, YesodPersist master
|
||||
, Typeable val
|
||||
) => HandlerT master IO (Maybe (AuthId master))
|
||||
#endif
|
||||
defaultMaybeAuthId = do
|
||||
ms <- lookupSession credsKey
|
||||
case ms of
|
||||
@ -238,7 +211,6 @@ defaultMaybeAuthId = do
|
||||
Nothing -> return Nothing
|
||||
Just aid -> fmap (fmap entityKey) $ cachedAuth aid
|
||||
|
||||
#if MIN_VERSION_persistent(2, 0, 0)
|
||||
cachedAuth :: ( YesodAuth master
|
||||
, b ~ YesodPersistBackend master
|
||||
, b ~ PersistEntityBackend val
|
||||
@ -248,17 +220,6 @@ cachedAuth :: ( YesodAuth master
|
||||
, YesodPersist master
|
||||
, Typeable val
|
||||
) => AuthId master -> HandlerT master IO (Maybe (Entity val))
|
||||
#else
|
||||
cachedAuth :: ( YesodAuth master
|
||||
, PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val
|
||||
, b ~ YesodPersistBackend master
|
||||
, Key val ~ AuthId master
|
||||
, PersistStore (b (HandlerT master IO))
|
||||
, PersistEntity val
|
||||
, YesodPersist master
|
||||
, Typeable val
|
||||
) => AuthId master -> HandlerT master IO (Maybe (Entity val))
|
||||
#endif
|
||||
cachedAuth aid = runMaybeT $ do
|
||||
a <- MaybeT $ fmap unCachedMaybeAuth
|
||||
$ cached
|
||||
@ -411,7 +372,6 @@ handlePluginR plugin pieces = do
|
||||
-- assumes that you are using a Persistent database.
|
||||
--
|
||||
-- Since 1.1.0
|
||||
#if MIN_VERSION_persistent(2, 0, 0)
|
||||
maybeAuth :: ( YesodAuth master
|
||||
, b ~ YesodPersistBackend master
|
||||
, b ~ PersistEntityBackend val
|
||||
@ -421,17 +381,6 @@ maybeAuth :: ( YesodAuth master
|
||||
, YesodPersist master
|
||||
, Typeable val
|
||||
) => HandlerT master IO (Maybe (Entity val))
|
||||
#else
|
||||
maybeAuth :: ( YesodAuth master
|
||||
, PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val
|
||||
, b ~ YesodPersistBackend master
|
||||
, Key val ~ AuthId master
|
||||
, PersistStore (b (HandlerT master IO))
|
||||
, PersistEntity val
|
||||
, YesodPersist master
|
||||
, Typeable val
|
||||
) => HandlerT master IO (Maybe (Entity val))
|
||||
#endif
|
||||
maybeAuth = runMaybeT $ do
|
||||
aid <- MaybeT maybeAuthId
|
||||
MaybeT $ cachedAuth aid
|
||||
@ -445,7 +394,6 @@ newtype CachedMaybeAuth val = CachedMaybeAuth { unCachedMaybeAuth :: Maybe val }
|
||||
-- full informatin on a given user.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
#if MIN_VERSION_persistent(2, 0, 0)
|
||||
type YesodAuthPersist master =
|
||||
( YesodAuth master
|
||||
, YesodPersistBackend master
|
||||
@ -456,18 +404,6 @@ type YesodAuthPersist master =
|
||||
, YesodPersist master
|
||||
, Typeable (AuthEntity master)
|
||||
)
|
||||
#else
|
||||
type YesodAuthPersist master =
|
||||
( YesodAuth master
|
||||
, PersistMonadBackend (YesodPersistBackend master (HandlerT master IO))
|
||||
~ PersistEntityBackend (AuthEntity master)
|
||||
, Key (AuthEntity master) ~ AuthId master
|
||||
, PersistStore (YesodPersistBackend master (HandlerT master IO))
|
||||
, PersistEntity (AuthEntity master)
|
||||
, YesodPersist master
|
||||
, Typeable (AuthEntity master)
|
||||
)
|
||||
#endif
|
||||
|
||||
-- | If the @AuthId@ for a given site is a persistent ID, this will give the
|
||||
-- value for that entity. E.g.:
|
||||
@ -477,10 +413,8 @@ type YesodAuthPersist master =
|
||||
--
|
||||
-- Since 1.2.0
|
||||
type AuthEntity master = KeyEntity (AuthId master)
|
||||
#if MIN_VERSION_persistent(2, 0, 0)
|
||||
type family KeyEntity key
|
||||
type instance KeyEntity (Key x) = x
|
||||
#endif
|
||||
|
||||
-- | Similar to 'maybeAuthId', but redirects to a login page if user is not
|
||||
-- authenticated or responds with error 401 if this is an API client (expecting JSON).
|
||||
|
||||
@ -66,17 +66,11 @@ import GhcBuild (buildPackage,
|
||||
import qualified Config as GHC
|
||||
import Data.Streaming.Network (bindPortTCP)
|
||||
import Network (withSocketsDo)
|
||||
#if MIN_VERSION_http_conduit(2, 0, 0)
|
||||
import Network.HTTP.Conduit (conduitManagerSettings, newManager)
|
||||
import Data.Default.Class (def)
|
||||
#else
|
||||
import Network.HTTP.Conduit (def, newManager)
|
||||
#endif
|
||||
import Network.HTTP.ReverseProxy (ProxyDest (ProxyDest),
|
||||
waiProxyToSettings, wpsTimeout, wpsOnExc)
|
||||
#if MIN_VERSION_http_reverse_proxy(0, 2, 0)
|
||||
import qualified Network.HTTP.ReverseProxy as ReverseProxy
|
||||
#endif
|
||||
import Network.HTTP.Types (status200, status503)
|
||||
import Network.Socket (sClose)
|
||||
import Network.Wai (responseLBS, requestHeaders)
|
||||
@ -130,11 +124,7 @@ cabalProgram opts | isCabalDev opts = "cabal-dev"
|
||||
-- 3001, give an appropriate message to the user.
|
||||
reverseProxy :: DevelOpts -> I.IORef Int -> IO ()
|
||||
reverseProxy opts iappPort = do
|
||||
#if MIN_VERSION_http_conduit(2, 0, 0)
|
||||
manager <- newManager conduitManagerSettings
|
||||
#else
|
||||
manager <- newManager def
|
||||
#endif
|
||||
let refreshHtml = LB.fromChunks $ return $(embedFile "refreshing.html")
|
||||
let onExc _ req
|
||||
| maybe False (("application/json" `elem`) . parseHttpAccept)
|
||||
@ -154,18 +144,10 @@ reverseProxy opts iappPort = do
|
||||
(const $ do
|
||||
appPort <- liftIO $ I.readIORef iappPort
|
||||
return $
|
||||
#if MIN_VERSION_http_reverse_proxy(0, 2, 0)
|
||||
ReverseProxy.WPRProxyDest
|
||||
#else
|
||||
Right
|
||||
#endif
|
||||
$ ProxyDest "127.0.0.1" appPort)
|
||||
def
|
||||
#if MIN_VERSION_wai(3, 0, 0)
|
||||
{ wpsOnExc = \e req f -> onExc e req >>= f
|
||||
#else
|
||||
{ wpsOnExc = onExc
|
||||
#endif
|
||||
, wpsTimeout =
|
||||
if proxyTimeout opts == 0
|
||||
then Nothing
|
||||
|
||||
@ -76,15 +76,9 @@ injectDefaultP env path p@(OptP o)
|
||||
p <|> if any ((==Just "1") . getEnvValue env path) names then pure a else empty
|
||||
| otherwise = p
|
||||
where
|
||||
#if MIN_VERSION_optparse_applicative(0,6,0)
|
||||
right= ReadM . Right
|
||||
left = ReadM . Left
|
||||
either' f g (ReadM x) = either f g x
|
||||
#else
|
||||
right = Right
|
||||
left = Left
|
||||
either' = either
|
||||
#endif
|
||||
injectDefaultP env path (MultP p1 p2) =
|
||||
MultP (injectDefaultP env path p1) (injectDefaultP env path p2)
|
||||
injectDefaultP env path (AltP p1 p2) =
|
||||
|
||||
@ -15,11 +15,7 @@ import Options (injectDefaults)
|
||||
import qualified Paths_yesod_bin
|
||||
import Scaffolding.Scaffolder
|
||||
|
||||
#if MIN_VERSION_optparse_applicative(0,6,0)
|
||||
import Options.Applicative.Types (ReadM (ReadM))
|
||||
#else
|
||||
import Options.Applicative.Builder.Internal (Mod, OptionFields)
|
||||
#endif
|
||||
|
||||
import HsFile (mkHsFile)
|
||||
#ifndef WINDOWS
|
||||
@ -155,12 +151,6 @@ keterOptions = Keter <$> switch ( long "nobuild" <> short 'n' <> help "Skip rebu
|
||||
defaultRescan :: Int
|
||||
defaultRescan = 10
|
||||
|
||||
#if MIN_VERSION_optparse_applicative(0,10,0)
|
||||
option' = option auto
|
||||
#else
|
||||
option' = option
|
||||
#endif
|
||||
|
||||
develOptions :: Parser Command
|
||||
develOptions = Devel <$> switch ( long "disable-api" <> short 'd'
|
||||
<> help "Disable fast GHC API rebuilding")
|
||||
@ -168,7 +158,7 @@ develOptions = Devel <$> switch ( long "disable-api" <> short 'd'
|
||||
<> help "Run COMMAND after rebuild succeeds")
|
||||
<*> optStr ( long "failure-hook" <> short 'f' <> metavar "COMMAND"
|
||||
<> help "Run COMMAND when rebuild fails")
|
||||
<*> option' ( long "event-timeout" <> short 't' <> value defaultRescan <> metavar "N"
|
||||
<*> option auto ( long "event-timeout" <> short 't' <> value defaultRescan <> metavar "N"
|
||||
<> help ("Force rescan of files every N seconds (default "
|
||||
++ show defaultRescan
|
||||
++ ", use -1 to rely on FSNotify alone)") )
|
||||
@ -178,9 +168,9 @@ develOptions = Devel <$> switch ( long "disable-api" <> short 'd'
|
||||
<> help "ignore file changes in DIR" )
|
||||
)
|
||||
<*> extraCabalArgs
|
||||
<*> option' ( long "port" <> short 'p' <> value 3000 <> metavar "N"
|
||||
<*> option auto ( long "port" <> short 'p' <> value 3000 <> metavar "N"
|
||||
<> help "Devel server listening port" )
|
||||
<*> option' ( long "proxy-timeout" <> short 'x' <> value 0 <> metavar "N"
|
||||
<*> option auto ( long "proxy-timeout" <> short 'x' <> value 0 <> metavar "N"
|
||||
<> help "Devel server timeout before returning 'not ready' message (in seconds, 0 for none)" )
|
||||
<*> switch ( long "disable-reverse-proxy" <> short 'n'
|
||||
<> help "Disable reverse proxy" )
|
||||
@ -195,17 +185,9 @@ extraCabalArgs = many (strOption ( long "extra-cabal-arg" <> short 'e' <> metava
|
||||
-- | Optional @String@ argument
|
||||
optStr :: Mod OptionFields (Maybe String) -> Parser (Maybe String)
|
||||
optStr m =
|
||||
#if MIN_VERSION_optparse_applicative(0,10,0)
|
||||
nullOption (success . str) $ value Nothing <> m
|
||||
#else
|
||||
nullOption $ value Nothing <> reader (success . str) <> m
|
||||
#endif
|
||||
where
|
||||
#if MIN_VERSION_optparse_applicative(0,6,0)
|
||||
success = ReadM . Right
|
||||
#else
|
||||
success = Right
|
||||
#endif
|
||||
|
||||
-- | Like @rawSystem@, but exits if it receives a non-success result.
|
||||
rawSystem' :: String -> [String] -> IO ()
|
||||
|
||||
@ -70,7 +70,7 @@ executable yesod
|
||||
, system-fileio >= 0.3 && < 0.4
|
||||
, unordered-containers
|
||||
, yaml >= 0.8 && < 0.9
|
||||
, optparse-applicative >= 0.5
|
||||
, optparse-applicative >= 0.10
|
||||
, fsnotify >= 0.0 && < 0.2
|
||||
, split >= 0.2 && < 0.3
|
||||
, file-embed
|
||||
@ -79,9 +79,9 @@ executable yesod
|
||||
, resourcet >= 0.3 && < 1.2
|
||||
, base64-bytestring
|
||||
, lifted-base
|
||||
, http-reverse-proxy >= 0.1.1
|
||||
, http-reverse-proxy >= 0.4
|
||||
, network
|
||||
, http-conduit
|
||||
, http-conduit >= 2.1.4
|
||||
, project-template >= 0.1.1
|
||||
, transformers
|
||||
, warp >= 1.3.7.5
|
||||
|
||||
@ -61,9 +61,6 @@ GOX(Monoid w, RWST r w s)
|
||||
GOX(Monoid w, Strict.RWST r w s)
|
||||
GO(Strict.StateT s)
|
||||
GOX(Monoid w, Strict.WriterT w)
|
||||
#if !MIN_VERSION_resourcet(1,1,0)
|
||||
GO(ExceptionT)
|
||||
#endif
|
||||
GO(Pipe l i o u)
|
||||
GO(ConduitM i o)
|
||||
#undef GO
|
||||
@ -87,9 +84,6 @@ GOX(Monoid w, RWST r w s)
|
||||
GOX(Monoid w, Strict.RWST r w s)
|
||||
GO(Strict.StateT s)
|
||||
GOX(Monoid w, Strict.WriterT w)
|
||||
#if !MIN_VERSION_resourcet(1,1,0)
|
||||
GO(ExceptionT)
|
||||
#endif
|
||||
GO(Pipe l i o u)
|
||||
GO(ConduitM i o)
|
||||
#undef GO
|
||||
|
||||
@ -40,16 +40,9 @@ import Data.Default (def)
|
||||
import Network.Wai.Parse (lbsBackEnd,
|
||||
tempFileBackEnd)
|
||||
import System.IO (stdout)
|
||||
#if MIN_VERSION_fast_logger(2, 0, 0)
|
||||
import Network.Wai.Logger (ZonedDate, clockDateCacher)
|
||||
import System.Log.FastLogger
|
||||
import qualified GHC.IO.FD
|
||||
#else
|
||||
import System.Log.FastLogger.Date (ZonedDate)
|
||||
import System.Log.FastLogger (LogStr (..), Logger,
|
||||
loggerDate, loggerPutStr,
|
||||
mkLogger)
|
||||
#endif
|
||||
import Text.Blaze (customAttribute, textTag,
|
||||
toValue, (!))
|
||||
import Text.Blaze (preEscapedToMarkup)
|
||||
@ -216,18 +209,10 @@ class RenderRoute site => Yesod site where
|
||||
--
|
||||
-- Default: Sends to stdout and automatically flushes on each write.
|
||||
makeLogger :: site -> IO Logger
|
||||
#if MIN_VERSION_fast_logger(2, 0, 0)
|
||||
makeLogger _ = do
|
||||
#if MIN_VERSION_fast_logger(2, 1, 0)
|
||||
loggerSet <- newLoggerSet defaultBufSize Nothing
|
||||
#else
|
||||
loggerSet <- newLoggerSet defaultBufSize GHC.IO.FD.stdout
|
||||
#endif
|
||||
(getter, _) <- clockDateCacher
|
||||
return $! Logger loggerSet getter
|
||||
#else
|
||||
makeLogger _ = mkLogger True stdout
|
||||
#endif
|
||||
|
||||
-- | Send a message to the @Logger@ provided by @getLogger@.
|
||||
--
|
||||
@ -541,7 +526,6 @@ asyncHelper render scripts jscript jsLoc =
|
||||
Nothing -> Nothing
|
||||
Just j -> Just $ jelper j
|
||||
|
||||
#if MIN_VERSION_fast_logger(2, 0, 0)
|
||||
formatLogMessage :: IO ZonedDate
|
||||
-> Loc
|
||||
-> LogSource
|
||||
@ -564,33 +548,6 @@ formatLogMessage getdate loc src level msg = do
|
||||
" @(" `mappend`
|
||||
toLogStr (fileLocationToString loc) `mappend`
|
||||
")\n"
|
||||
#else
|
||||
formatLogMessage :: IO ZonedDate
|
||||
-> Loc
|
||||
-> LogSource
|
||||
-> LogLevel
|
||||
-> LogStr -- ^ message
|
||||
-> IO [LogStr]
|
||||
formatLogMessage getdate loc src level msg = do
|
||||
now <- getdate
|
||||
return
|
||||
[ LB now
|
||||
, LB " ["
|
||||
, LS $
|
||||
case level of
|
||||
LevelOther t -> T.unpack t
|
||||
_ -> drop 5 $ show level
|
||||
, LS $
|
||||
if T.null src
|
||||
then ""
|
||||
else "#" ++ T.unpack src
|
||||
, LB "] "
|
||||
, msg
|
||||
, LB " @("
|
||||
, LS $ fileLocationToString loc
|
||||
, LB ")\n"
|
||||
]
|
||||
#endif
|
||||
|
||||
-- | Customize the cookies used by the session backend. You may
|
||||
-- use this function on your definition of 'makeSessionBackend'.
|
||||
|
||||
@ -63,9 +63,7 @@ import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
|
||||
import Data.Conduit (Source, Flush (Chunk), ResumableSource, mapOutput)
|
||||
import Control.Monad.Trans.Resource (ResourceT)
|
||||
import Data.Conduit.Internal (ResumableSource (ResumableSource))
|
||||
#if MIN_VERSION_conduit(1, 2, 0)
|
||||
import qualified Data.Conduit.Internal as CI
|
||||
#endif
|
||||
|
||||
import qualified Data.Aeson as J
|
||||
import Data.Aeson.Encode (fromValue)
|
||||
@ -118,10 +116,8 @@ instance ToContent Css where
|
||||
instance ToContent Javascript where
|
||||
toContent = toContent . toLazyText . unJavascript
|
||||
|
||||
#if MIN_VERSION_conduit(1, 2, 0)
|
||||
instance ToFlushBuilder builder => ToContent (CI.Pipe () () builder () (ResourceT IO) ()) where
|
||||
toContent src = ContentSource $ CI.ConduitM (CI.mapOutput toFlushBuilder src >>=)
|
||||
#endif
|
||||
|
||||
instance ToFlushBuilder builder => ToContent (Source (ResourceT IO) builder) where
|
||||
toContent src = ContentSource $ mapOutput toFlushBuilder src
|
||||
|
||||
@ -92,13 +92,8 @@ toWaiAppYre yre req =
|
||||
where
|
||||
site = yreSite yre
|
||||
sendRedirect :: Yesod master => master -> [Text] -> W.Application
|
||||
#if MIN_VERSION_wai(3, 0, 0)
|
||||
sendRedirect y segments' env sendResponse =
|
||||
sendResponse $ W.responseLBS status301
|
||||
#else
|
||||
sendRedirect y segments' env =
|
||||
return $ W.responseLBS status301
|
||||
#endif
|
||||
[ ("Content-Type", "text/plain")
|
||||
, ("Location", Blaze.ByteString.Builder.toByteString dest')
|
||||
] "Redirecting"
|
||||
@ -180,12 +175,7 @@ warp port site = do
|
||||
(toLogStr $ "Exception from Warp: " ++ show e)
|
||||
}
|
||||
where
|
||||
shouldLog' =
|
||||
#if MIN_VERSION_warp(2,1,3)
|
||||
Network.Wai.Handler.Warp.defaultShouldDisplayException
|
||||
#else
|
||||
const True
|
||||
#endif
|
||||
shouldLog' = Network.Wai.Handler.Warp.defaultShouldDisplayException
|
||||
|
||||
-- | A default set of middlewares.
|
||||
--
|
||||
@ -193,11 +183,7 @@ warp port site = do
|
||||
mkDefaultMiddlewares :: Logger -> IO W.Middleware
|
||||
mkDefaultMiddlewares logger = do
|
||||
logWare <- mkRequestLogger def
|
||||
#if MIN_VERSION_fast_logger(2, 0, 0)
|
||||
{ destination = Network.Wai.Middleware.RequestLogger.Logger $ loggerSet logger
|
||||
#else
|
||||
{ destination = Logger logger
|
||||
#endif
|
||||
, outputFormat = Apache FromSocket
|
||||
}
|
||||
return $ logWare . defaultMiddlewaresNoLogging
|
||||
|
||||
@ -92,12 +92,8 @@ module Yesod.Core.Handler
|
||||
, sendResponseCreated
|
||||
, sendWaiResponse
|
||||
, sendWaiApplication
|
||||
#if MIN_VERSION_wai(2, 1, 0)
|
||||
, sendRawResponse
|
||||
#endif
|
||||
#if MIN_VERSION_wai(3, 0, 0)
|
||||
, sendRawResponseNoConduit
|
||||
#endif
|
||||
-- * Different representations
|
||||
-- $representations
|
||||
, selectRep
|
||||
@ -206,21 +202,11 @@ import Data.CaseInsensitive (CI)
|
||||
import qualified Data.Conduit.List as CL
|
||||
import Control.Monad (unless)
|
||||
import Control.Monad.Trans.Resource (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO
|
||||
#if MIN_VERSION_wai(2, 0, 0)
|
||||
#else
|
||||
, ResourceT
|
||||
#endif
|
||||
)
|
||||
#if MIN_VERSION_wai(2, 0, 0)
|
||||
import qualified System.PosixCompat.Files as PC
|
||||
#endif
|
||||
#if MIN_VERSION_wai(2, 1, 0)
|
||||
import Control.Monad.Trans.Control (control, MonadBaseControl)
|
||||
#endif
|
||||
import Data.Conduit (Source, transPipe, Flush (Flush), yield, Producer
|
||||
#if MIN_VERSION_wai(2, 1, 0)
|
||||
, Sink
|
||||
#endif
|
||||
)
|
||||
|
||||
get :: MonadHandler m => m GHState
|
||||
@ -257,41 +243,22 @@ runRequestBody = do
|
||||
Just rbc -> return rbc
|
||||
Nothing -> do
|
||||
rr <- waiRequest
|
||||
#if MIN_VERSION_wai_extra(2, 0, 1)
|
||||
internalState <- liftResourceT getInternalState
|
||||
rbc <- liftIO $ rbHelper upload rr internalState
|
||||
#elif MIN_VERSION_wai(2, 0, 0)
|
||||
rbc <- liftIO $ rbHelper upload rr
|
||||
#else
|
||||
rbc <- liftResourceT $ rbHelper upload rr
|
||||
#endif
|
||||
put x { ghsRBC = Just rbc }
|
||||
return rbc
|
||||
|
||||
#if MIN_VERSION_wai(2, 0, 0)
|
||||
rbHelper :: FileUpload -> W.Request -> InternalState -> IO RequestBodyContents
|
||||
rbHelper upload req internalState =
|
||||
#else
|
||||
rbHelper :: FileUpload -> W.Request -> ResourceT IO RequestBodyContents
|
||||
rbHelper upload req =
|
||||
#endif
|
||||
case upload of
|
||||
FileUploadMemory s -> rbHelper' s mkFileInfoLBS req
|
||||
#if MIN_VERSION_wai_extra(2, 0, 1)
|
||||
FileUploadDisk s -> rbHelper' (s internalState) mkFileInfoFile req
|
||||
#else
|
||||
FileUploadDisk s -> rbHelper' s mkFileInfoFile req
|
||||
#endif
|
||||
FileUploadSource s -> rbHelper' s mkFileInfoSource req
|
||||
|
||||
rbHelper' :: NWP.BackEnd x
|
||||
-> (Text -> Text -> x -> FileInfo)
|
||||
-> W.Request
|
||||
#if MIN_VERSION_wai(2, 0, 0)
|
||||
-> IO ([(Text, Text)], [(Text, FileInfo)])
|
||||
#else
|
||||
-> ResourceT IO ([(Text, Text)], [(Text, FileInfo)])
|
||||
#endif
|
||||
rbHelper' backend mkFI req =
|
||||
(map fix1 *** mapMaybe fix2) <$> (NWP.parseRequestBody backend req)
|
||||
where
|
||||
@ -375,11 +342,7 @@ handlerToIO =
|
||||
where
|
||||
oldReq = handlerRequest oldHandlerData
|
||||
oldWaiReq = reqWaiRequest oldReq
|
||||
#if MIN_VERSION_wai(3, 0, 0)
|
||||
newWaiReq = oldWaiReq { W.requestBody = return mempty
|
||||
#else
|
||||
newWaiReq = oldWaiReq { W.requestBody = mempty
|
||||
#endif
|
||||
, W.requestBodyLength = W.KnownLength 0
|
||||
}
|
||||
oldEnv = handlerEnv oldHandlerData
|
||||
@ -551,16 +514,12 @@ sendFilePart :: MonadHandler m
|
||||
-> Integer -- ^ count
|
||||
-> m a
|
||||
sendFilePart ct fp off count = do
|
||||
#if MIN_VERSION_wai(2, 0, 0)
|
||||
fs <- liftIO $ PC.getFileStatus fp
|
||||
handlerError $ HCSendFile ct fp $ Just W.FilePart
|
||||
{ W.filePartOffset = off
|
||||
, W.filePartByteCount = count
|
||||
, W.filePartFileSize = fromIntegral $ PC.fileSize fs
|
||||
}
|
||||
#else
|
||||
handlerError $ HCSendFile ct fp $ Just $ W.FilePart off count
|
||||
#endif
|
||||
|
||||
-- | Bypass remaining handler code and output the given content with a 200
|
||||
-- status code.
|
||||
@ -593,7 +552,6 @@ sendWaiResponse = handlerError . HCWai
|
||||
sendWaiApplication :: MonadHandler m => W.Application -> m b
|
||||
sendWaiApplication = handlerError . HCWaiApp
|
||||
|
||||
#if MIN_VERSION_wai(3, 0, 0)
|
||||
-- | Send a raw response without conduit. This is used for cases such as
|
||||
-- WebSockets. Requires WAI 3.0 or later, and a web server which supports raw
|
||||
-- responses (e.g., Warp).
|
||||
@ -609,9 +567,7 @@ sendRawResponseNoConduit raw = control $ \runInIO ->
|
||||
where
|
||||
fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")]
|
||||
"sendRawResponse: backend does not support raw responses"
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_wai(2, 1, 0)
|
||||
-- | Send a raw response. This is used for cases such as WebSockets. Requires
|
||||
-- WAI 2.1 or later, and a web server which supports raw responses (e.g.,
|
||||
-- Warp).
|
||||
@ -620,7 +576,6 @@ sendRawResponseNoConduit raw = control $ \runInIO ->
|
||||
sendRawResponse :: (MonadHandler m, MonadBaseControl IO m)
|
||||
=> (Source IO S8.ByteString -> Sink S8.ByteString IO () -> m ())
|
||||
-> m a
|
||||
#if MIN_VERSION_wai(3, 0, 0)
|
||||
sendRawResponse raw = control $ \runInIO ->
|
||||
runInIO $ sendWaiResponse $ flip W.responseRaw fallback
|
||||
$ \src sink -> runInIO (raw (src' src) (CL.mapM_ sink)) >> return ()
|
||||
@ -632,15 +587,6 @@ sendRawResponse raw = control $ \runInIO ->
|
||||
unless (S.null bs) $ do
|
||||
yield bs
|
||||
src' src
|
||||
#else
|
||||
sendRawResponse raw = control $ \runInIO ->
|
||||
runInIO $ sendWaiResponse $ flip W.responseRaw fallback
|
||||
$ \src sink -> runInIO (raw src sink) >> return ()
|
||||
where
|
||||
fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")]
|
||||
"sendRawResponse: backend does not support raw responses"
|
||||
#endif
|
||||
#endif
|
||||
|
||||
-- | Return a 404 not found page. Also denotes no handler available.
|
||||
notFound :: MonadHandler m => m a
|
||||
@ -1126,22 +1072,12 @@ provideRepType ct handler =
|
||||
rawRequestBody :: MonadHandler m => Source m S.ByteString
|
||||
rawRequestBody = do
|
||||
req <- lift waiRequest
|
||||
#if MIN_VERSION_wai(3, 0, 0)
|
||||
let loop = do
|
||||
bs <- liftIO $ W.requestBody req
|
||||
unless (S.null bs) $ do
|
||||
yield bs
|
||||
loop
|
||||
loop
|
||||
#else
|
||||
transPipe
|
||||
#if MIN_VERSION_wai(2, 0, 0)
|
||||
liftIO
|
||||
#else
|
||||
liftResourceT
|
||||
#endif
|
||||
(W.requestBody req)
|
||||
#endif
|
||||
|
||||
-- | Stream the data from the file. Since Yesod 1.2, this has been generalized
|
||||
-- to work in any @MonadResource@.
|
||||
|
||||
@ -48,7 +48,6 @@ import Data.IORef
|
||||
|
||||
-- | Impose a limit on the size of the request body.
|
||||
limitRequestBody :: Word64 -> W.Request -> IO W.Request
|
||||
#if MIN_VERSION_wai(3, 0, 0)
|
||||
limitRequestBody maxLen req = do
|
||||
ref <- newIORef maxLen
|
||||
return req
|
||||
@ -63,24 +62,6 @@ limitRequestBody maxLen req = do
|
||||
writeIORef ref remaining'
|
||||
return bs
|
||||
}
|
||||
#else
|
||||
limitRequestBody maxLen req =
|
||||
return req { W.requestBody = W.requestBody req $= limit maxLen }
|
||||
where
|
||||
tooLarge = liftIO $ throwIO $ HCWai tooLargeResponse
|
||||
|
||||
limit 0 = tooLarge
|
||||
limit remaining =
|
||||
await >>= maybe (return ()) go
|
||||
where
|
||||
go bs = do
|
||||
let len = fromIntegral $ S8.length bs
|
||||
if len > remaining
|
||||
then tooLarge
|
||||
else do
|
||||
yield bs
|
||||
limit $ remaining - len
|
||||
#endif
|
||||
|
||||
tooLargeResponse :: W.Response
|
||||
tooLargeResponse = W.responseLBS
|
||||
|
||||
@ -13,13 +13,11 @@ import qualified Data.ByteString.Char8 as S8
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Network.Wai
|
||||
#if MIN_VERSION_wai(2, 0, 0)
|
||||
import Data.Conduit (transPipe)
|
||||
import Control.Monad.Trans.Resource (runInternalState, getInternalState, runResourceT, InternalState, closeInternalState)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Network.Wai.Internal
|
||||
import Control.Exception (finally)
|
||||
#endif
|
||||
import Prelude hiding (catch)
|
||||
import Web.Cookie (renderSetCookie)
|
||||
import Yesod.Core.Content
|
||||
@ -36,7 +34,6 @@ import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Conduit (Flush (..), ($$))
|
||||
import qualified Data.Conduit.List as CL
|
||||
|
||||
#if MIN_VERSION_wai(3, 0, 0)
|
||||
yarToResponse :: YesodResponse
|
||||
-> (SessionMap -> IO [Header]) -- ^ save session
|
||||
-> YesodRequest
|
||||
@ -77,82 +74,6 @@ yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq req is sendResponse
|
||||
| s' == defaultStatus = H.status200
|
||||
| otherwise = s'
|
||||
|
||||
#else
|
||||
yarToResponse :: YesodResponse
|
||||
-> (SessionMap -> IO [Header]) -- ^ save session
|
||||
-> YesodRequest
|
||||
-> Request
|
||||
#if MIN_VERSION_wai(2, 0, 0)
|
||||
-> InternalState
|
||||
#endif
|
||||
-> IO Response
|
||||
#if MIN_VERSION_wai(2, 0, 0)
|
||||
yarToResponse (YRWaiApp app) _ _ req _ = app req
|
||||
yarToResponse (YRWai a) _ _ _ is =
|
||||
case a of
|
||||
ResponseSource s hs w -> return $ ResponseSource s hs $ \f ->
|
||||
w f `finally` closeInternalState is
|
||||
ResponseBuilder{} -> do
|
||||
closeInternalState is
|
||||
return a
|
||||
ResponseFile{} -> do
|
||||
closeInternalState is
|
||||
return a
|
||||
#if MIN_VERSION_wai(2, 1, 0)
|
||||
-- Ignore the fallback provided, in case it refers to a ResourceT state
|
||||
-- in a ResponseSource.
|
||||
ResponseRaw raw _ -> return $ ResponseRaw
|
||||
(\f -> raw f `finally` closeInternalState is)
|
||||
(responseLBS H.status500 [("Content-Type", "text/plain")]
|
||||
"yarToResponse: backend does not support raw responses")
|
||||
#endif
|
||||
#else
|
||||
yarToResponse (YRWai a) _ _ _ = return a
|
||||
#endif
|
||||
yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq req
|
||||
#if MIN_VERSION_wai(2, 0, 0)
|
||||
is
|
||||
#endif
|
||||
= do
|
||||
extraHeaders <- do
|
||||
let nsToken = maybe
|
||||
newSess
|
||||
(\n -> Map.insert tokenKey (encodeUtf8 n) newSess)
|
||||
(reqToken yreq)
|
||||
sessionHeaders <- saveSession nsToken
|
||||
return $ ("Content-Type", ct) : map headerToPair sessionHeaders
|
||||
let finalHeaders = extraHeaders ++ map headerToPair hs
|
||||
finalHeaders' len = ("Content-Length", S8.pack $ show len)
|
||||
: finalHeaders
|
||||
|
||||
#if MIN_VERSION_wai(2, 0, 0)
|
||||
let go (ContentBuilder b mlen) = do
|
||||
let hs' = maybe finalHeaders finalHeaders' mlen
|
||||
closeInternalState is
|
||||
return $ ResponseBuilder s hs' b
|
||||
go (ContentFile fp p) = do
|
||||
closeInternalState is
|
||||
return $ ResponseFile s finalHeaders fp p
|
||||
go (ContentSource body) = return $ ResponseSource s finalHeaders $ \f ->
|
||||
f (transPipe (flip runInternalState is) body) `finally`
|
||||
closeInternalState is
|
||||
go (ContentDontEvaluate c') = go c'
|
||||
go c
|
||||
#else
|
||||
let go (ContentBuilder b mlen) =
|
||||
let hs' = maybe finalHeaders finalHeaders' mlen
|
||||
in ResponseBuilder s hs' b
|
||||
go (ContentFile fp p) = ResponseFile s finalHeaders fp p
|
||||
go (ContentSource body) = ResponseSource s finalHeaders body
|
||||
go (ContentDontEvaluate c') = go c'
|
||||
return $ go c
|
||||
#endif
|
||||
where
|
||||
s
|
||||
| s' == defaultStatus = H.status200
|
||||
| otherwise = s'
|
||||
#endif
|
||||
|
||||
-- | Indicates that the user provided no specific status code to be used, and
|
||||
-- therefore the default status code should be used. For normal responses, this
|
||||
-- would be a 200 response, whereas for error responses this would be an
|
||||
|
||||
@ -34,13 +34,8 @@ import Data.Text.Encoding.Error (lenientDecode)
|
||||
import Language.Haskell.TH.Syntax (Loc, qLocation)
|
||||
import qualified Network.HTTP.Types as H
|
||||
import Network.Wai
|
||||
#if MIN_VERSION_wai(2, 0, 0)
|
||||
import Network.Wai.Internal
|
||||
#endif
|
||||
import Prelude hiding (catch)
|
||||
#if !MIN_VERSION_fast_logger(2, 0, 0)
|
||||
import System.Log.FastLogger (Logger)
|
||||
#endif
|
||||
import System.Log.FastLogger (LogStr, toLogStr)
|
||||
import System.Random (newStdGen)
|
||||
import Yesod.Core.Content
|
||||
@ -220,22 +215,13 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
|
||||
, httpVersion = H.http11
|
||||
, rawPathInfo = "/runFakeHandler/pathInfo"
|
||||
, rawQueryString = ""
|
||||
#if MIN_VERSION_wai(2, 0, 0)
|
||||
, requestHeaderHost = Nothing
|
||||
#else
|
||||
, serverName = "runFakeHandler-serverName"
|
||||
, serverPort = 80
|
||||
#endif
|
||||
, requestHeaders = []
|
||||
, isSecure = False
|
||||
, remoteHost = error "runFakeHandler-remoteHost"
|
||||
, pathInfo = ["runFakeHandler", "pathInfo"]
|
||||
, queryString = []
|
||||
#if MIN_VERSION_wai(3, 0, 0)
|
||||
, requestBody = return mempty
|
||||
#else
|
||||
, requestBody = mempty
|
||||
#endif
|
||||
, vault = mempty
|
||||
, requestBodyLength = KnownLength 0
|
||||
}
|
||||
@ -258,13 +244,8 @@ yesodRunner :: (ToTypedContent res, Yesod site)
|
||||
-> YesodRunnerEnv site
|
||||
-> Maybe (Route site)
|
||||
-> Application
|
||||
#if MIN_VERSION_wai(3, 0, 0)
|
||||
yesodRunner handler' YesodRunnerEnv {..} route req sendResponse
|
||||
| Just maxLen <- mmaxLen, KnownLength len <- requestBodyLength req, maxLen < len = sendResponse tooLargeResponse
|
||||
#else
|
||||
yesodRunner handler' YesodRunnerEnv {..} route req
|
||||
| Just maxLen <- mmaxLen, KnownLength len <- requestBodyLength req, maxLen < len = return tooLargeResponse
|
||||
#endif
|
||||
| otherwise = do
|
||||
let dontSaveSession _ = return []
|
||||
(session, saveSession) <- liftIO $ do
|
||||
@ -291,25 +272,11 @@ yesodRunner handler' YesodRunnerEnv {..} route req
|
||||
rhe = rheSafe
|
||||
{ rheOnError = runHandler rheSafe . errorHandler
|
||||
}
|
||||
#if MIN_VERSION_wai(3, 0, 0)
|
||||
|
||||
E.bracket createInternalState closeInternalState $ \is -> do
|
||||
yreq' <- yreq
|
||||
yar <- runInternalState (runHandler rhe handler yreq') is
|
||||
yarToResponse yar saveSession yreq' req is sendResponse
|
||||
|
||||
#else
|
||||
|
||||
#if MIN_VERSION_wai(2, 0, 0)
|
||||
bracketOnError createInternalState closeInternalState $ \is -> do
|
||||
yreq' <- yreq
|
||||
yar <- runInternalState (runHandler rhe handler yreq') is
|
||||
liftIO $ yarToResponse yar saveSession yreq' req is
|
||||
#else
|
||||
yar <- runHandler rhe handler yreq
|
||||
liftIO $ yarToResponse yar saveSession yreq req
|
||||
#endif
|
||||
#endif
|
||||
where
|
||||
mmaxLen = maximumContentLength yreSite route
|
||||
handler = yesodMiddleware handler'
|
||||
|
||||
@ -95,11 +95,7 @@ provideJson = provideRep . return . J.toJSON
|
||||
-- /Since: 0.3.0/
|
||||
parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
|
||||
parseJsonBody = do
|
||||
#if MIN_VERSION_resourcet(1,1,0)
|
||||
eValue <- rawRequestBody $$ runCatchC (sinkParser JP.value')
|
||||
#else
|
||||
eValue <- runExceptionT $ rawRequestBody $$ sinkParser JP.value'
|
||||
#endif
|
||||
return $ case eValue of
|
||||
Left e -> J.Error $ show e
|
||||
Right value -> J.fromJSON value
|
||||
|
||||
@ -5,7 +5,6 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Yesod.Core.Types where
|
||||
|
||||
import qualified Blaze.ByteString.Builder as BBuilder
|
||||
@ -17,17 +16,12 @@ import Control.Exception (Exception)
|
||||
import Control.Monad (liftM, ap)
|
||||
import Control.Monad.Base (MonadBase (liftBase))
|
||||
import Control.Monad.Catch (MonadCatch (..))
|
||||
#if MIN_VERSION_exceptions(0,6,0)
|
||||
import Control.Monad.Catch (MonadMask (..))
|
||||
#endif
|
||||
import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||
import Control.Monad.Logger (LogLevel, LogSource,
|
||||
MonadLogger (..))
|
||||
import Control.Monad.Trans.Control (MonadBaseControl (..))
|
||||
import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState, MonadThrow (..), monadThrow, ResourceT)
|
||||
#if !MIN_VERSION_resourcet(1,1,0)
|
||||
import Control.Monad.Trans.Resource (MonadUnsafeIO (..))
|
||||
#endif
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.Conduit (Flush, Source)
|
||||
@ -52,12 +46,8 @@ import Network.Wai (FilePart,
|
||||
RequestBodyLength)
|
||||
import qualified Network.Wai as W
|
||||
import qualified Network.Wai.Parse as NWP
|
||||
#if MIN_VERSION_fast_logger(2, 0, 0)
|
||||
import System.Log.FastLogger (LogStr, LoggerSet, toLogStr, pushLogStr)
|
||||
import Network.Wai.Logger (DateCacheGetter)
|
||||
#else
|
||||
import System.Log.FastLogger (LogStr, Logger, toLogStr)
|
||||
#endif
|
||||
import Text.Blaze.Html (Html)
|
||||
import Text.Hamlet (HtmlUrl)
|
||||
import Text.Julius (JavascriptUrl)
|
||||
@ -68,9 +58,7 @@ import Yesod.Routes.Class (RenderRoute (..), ParseRout
|
||||
import Control.Monad.Reader (MonadReader (..))
|
||||
import Prelude hiding (catch)
|
||||
import Control.DeepSeq (NFData (rnf))
|
||||
#if MIN_VERSION_conduit(1, 1, 0)
|
||||
import Data.Conduit.Lazy (MonadActive, monadActive)
|
||||
#endif
|
||||
|
||||
-- Sessions
|
||||
type SessionMap = Map Text ByteString
|
||||
@ -146,11 +134,7 @@ data FileInfo = FileInfo
|
||||
}
|
||||
|
||||
data FileUpload = FileUploadMemory !(NWP.BackEnd L.ByteString)
|
||||
#if MIN_VERSION_wai_extra(2, 0, 1)
|
||||
| FileUploadDisk !(InternalState -> NWP.BackEnd FilePath)
|
||||
#else
|
||||
| FileUploadDisk !(NWP.BackEnd FilePath)
|
||||
#endif
|
||||
| FileUploadSource !(NWP.BackEnd (Source (ResourceT IO) ByteString))
|
||||
|
||||
-- | How to determine the root of the application for constructing URLs.
|
||||
@ -423,14 +407,11 @@ instance Monad m => MonadReader site (WidgetT site m) where
|
||||
instance MonadTrans (WidgetT site) where
|
||||
lift = WidgetT . const . liftM (, mempty)
|
||||
instance MonadThrow m => MonadThrow (WidgetT site m) where
|
||||
#if MIN_VERSION_resourcet(1,1,0)
|
||||
throwM = lift . throwM
|
||||
|
||||
instance MonadCatch m => MonadCatch (HandlerT site m) where
|
||||
catch (HandlerT m) c = HandlerT $ \r -> m r `catch` \e -> unHandlerT (c e) r
|
||||
#if MIN_VERSION_exceptions(0,6,0)
|
||||
instance MonadMask m => MonadMask (HandlerT site m) where
|
||||
#endif
|
||||
mask a = HandlerT $ \e -> mask $ \u -> unHandlerT (a $ q u) e
|
||||
where q u (HandlerT b) = HandlerT (u . b)
|
||||
uninterruptibleMask a =
|
||||
@ -438,35 +419,24 @@ instance MonadMask m => MonadMask (HandlerT site m) where
|
||||
where q u (HandlerT b) = HandlerT (u . b)
|
||||
instance MonadCatch m => MonadCatch (WidgetT site m) where
|
||||
catch (WidgetT m) c = WidgetT $ \r -> m r `catch` \e -> unWidgetT (c e) r
|
||||
#if MIN_VERSION_exceptions(0,6,0)
|
||||
instance MonadMask m => MonadMask (WidgetT site m) where
|
||||
#endif
|
||||
mask a = WidgetT $ \e -> mask $ \u -> unWidgetT (a $ q u) e
|
||||
where q u (WidgetT b) = WidgetT (u . b)
|
||||
uninterruptibleMask a =
|
||||
WidgetT $ \e -> uninterruptibleMask $ \u -> unWidgetT (a $ q u) e
|
||||
where q u (WidgetT b) = WidgetT (u . b)
|
||||
#else
|
||||
monadThrow = lift . monadThrow
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_resourcet(1,1,0)
|
||||
instance (Applicative m, MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (WidgetT site m) where
|
||||
#else
|
||||
instance (Applicative m, MonadIO m, MonadUnsafeIO m, MonadThrow m) => MonadResource (WidgetT site m) where
|
||||
#endif
|
||||
liftResourceT f = WidgetT $ \hd -> liftIO $ fmap (, mempty) $ runInternalState f (handlerResource hd)
|
||||
|
||||
instance MonadIO m => MonadLogger (WidgetT site m) where
|
||||
monadLoggerLog a b c d = WidgetT $ \hd ->
|
||||
liftIO $ fmap (, mempty) $ rheLog (handlerEnv hd) a b c (toLogStr d)
|
||||
|
||||
#if MIN_VERSION_conduit(1, 1, 0)
|
||||
instance MonadActive m => MonadActive (WidgetT site m) where
|
||||
monadActive = lift monadActive
|
||||
instance MonadActive m => MonadActive (HandlerT site m) where
|
||||
monadActive = lift monadActive
|
||||
#endif
|
||||
|
||||
instance MonadTrans (HandlerT site) where
|
||||
lift = HandlerT . const
|
||||
@ -507,17 +477,9 @@ instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where
|
||||
restoreM (StH base) = HandlerT $ const $ restoreM base
|
||||
|
||||
instance MonadThrow m => MonadThrow (HandlerT site m) where
|
||||
#if MIN_VERSION_resourcet(1,1,0)
|
||||
throwM = lift . monadThrow
|
||||
#else
|
||||
monadThrow = lift . monadThrow
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_resourcet(1,1,0)
|
||||
instance (MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (HandlerT site m) where
|
||||
#else
|
||||
instance (MonadIO m, MonadUnsafeIO m, MonadThrow m) => MonadResource (HandlerT site m) where
|
||||
#endif
|
||||
liftResourceT f = HandlerT $ \hd -> liftIO $ runInternalState f (handlerResource hd)
|
||||
|
||||
instance MonadIO m => MonadLogger (HandlerT site m) where
|
||||
@ -538,7 +500,6 @@ instance RenderRoute WaiSubsite where
|
||||
instance ParseRoute WaiSubsite where
|
||||
parseRoute (x, y) = Just $ WaiSubsiteRoute x y
|
||||
|
||||
#if MIN_VERSION_fast_logger(2, 0, 0)
|
||||
data Logger = Logger
|
||||
{ loggerSet :: !LoggerSet
|
||||
, loggerDate :: !DateCacheGetter
|
||||
@ -546,4 +507,3 @@ data Logger = Logger
|
||||
|
||||
loggerPutStr :: Logger -> LogStr -> IO ()
|
||||
loggerPutStr (Logger ls _) = pushLogStr ls
|
||||
#endif
|
||||
|
||||
@ -15,9 +15,7 @@ import qualified YesodCoreTest.Redirect as Redirect
|
||||
import qualified YesodCoreTest.JsLoader as JsLoader
|
||||
import qualified YesodCoreTest.RequestBodySize as RequestBodySize
|
||||
import qualified YesodCoreTest.Json as Json
|
||||
#if MIN_VERSION_wai(2, 1, 0)
|
||||
import qualified YesodCoreTest.RawResponse as RawResponse
|
||||
#endif
|
||||
import qualified YesodCoreTest.Streaming as Streaming
|
||||
import qualified YesodCoreTest.Reps as Reps
|
||||
import qualified YesodCoreTest.Auth as Auth
|
||||
@ -41,9 +39,7 @@ specs = do
|
||||
JsLoader.specs
|
||||
RequestBodySize.specs
|
||||
Json.specs
|
||||
#if MIN_VERSION_wai(2, 1, 0)
|
||||
RawResponse.specs
|
||||
#endif
|
||||
Streaming.specs
|
||||
Reps.specs
|
||||
Auth.specs
|
||||
|
||||
@ -33,11 +33,7 @@ instance ParseRoute Subsite where
|
||||
parseRoute (x, _) = Just $ SubsiteRoute x
|
||||
|
||||
instance YesodSubDispatch Subsite master where
|
||||
#if MIN_VERSION_wai(3, 0, 0)
|
||||
yesodSubDispatch _ req f = f $ responseLBS
|
||||
#else
|
||||
yesodSubDispatch _ req = return $ responseLBS
|
||||
#endif
|
||||
status200
|
||||
[ ("Content-Type", "SUBSITE")
|
||||
] $ L8.pack $ show (pathInfo req)
|
||||
|
||||
@ -6,11 +6,7 @@ import Yesod.Core
|
||||
import qualified Network.HTTP.Types as H
|
||||
|
||||
myApp :: Application
|
||||
#if MIN_VERSION_wai(3, 0, 0)
|
||||
myApp _ f = f $ responseLBS H.status200 [("Content-type", "text/plain")] "WAI"
|
||||
#else
|
||||
myApp _ = return $ responseLBS H.status200 [("Content-type", "text/plain")] "WAI"
|
||||
#endif
|
||||
|
||||
getApp :: a -> WaiSubsite
|
||||
getApp _ = WaiSubsite myApp
|
||||
|
||||
@ -49,7 +49,7 @@ library
|
||||
, directory >= 1
|
||||
, vector >= 0.9 && < 0.11
|
||||
, aeson >= 0.5
|
||||
, fast-logger >= 0.2
|
||||
, fast-logger >= 2.1
|
||||
, wai-logger >= 0.2
|
||||
, monad-logger >= 0.3.1 && < 0.4
|
||||
, conduit >= 1.2
|
||||
@ -62,7 +62,7 @@ library
|
||||
, warp >= 1.3.8
|
||||
, unix-compat
|
||||
, conduit-extra
|
||||
, exceptions
|
||||
, exceptions >= 0.6
|
||||
, deepseq
|
||||
|
||||
exposed-modules: Yesod.Core
|
||||
|
||||
@ -75,11 +75,7 @@ import Data.Maybe (listToMaybe, fromMaybe)
|
||||
import qualified Blaze.ByteString.Builder.Html.Utf8 as B
|
||||
import Blaze.ByteString.Builder (writeByteString, toLazyByteString)
|
||||
import Blaze.ByteString.Builder.Internal.Write (fromWriteList)
|
||||
#if MIN_VERSION_persistent(2, 0, 0)
|
||||
import Database.Persist (PersistEntityBackend)
|
||||
#else
|
||||
import Database.Persist (PersistMonadBackend, PersistEntityBackend)
|
||||
#endif
|
||||
|
||||
import Text.Blaze.Html.Renderer.String (renderHtml)
|
||||
import qualified Data.ByteString as S
|
||||
@ -559,21 +555,12 @@ optionsPairs opts = do
|
||||
optionsEnum :: (MonadHandler m, Show a, Enum a, Bounded a) => m (OptionList a)
|
||||
optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
|
||||
|
||||
#if MIN_VERSION_persistent(2, 0, 0)
|
||||
optionsPersist :: ( YesodPersist site, PersistEntity a
|
||||
, PersistQuery (PersistEntityBackend a)
|
||||
, PathPiece (Key a)
|
||||
, RenderMessage site msg
|
||||
, YesodPersistBackend site ~ PersistEntityBackend a
|
||||
)
|
||||
#else
|
||||
optionsPersist :: ( YesodPersist site, PersistEntity a
|
||||
, PersistQuery (YesodPersistBackend site (HandlerT site IO))
|
||||
, PathPiece (Key a)
|
||||
, PersistEntityBackend a ~ PersistMonadBackend (YesodPersistBackend site (HandlerT site IO))
|
||||
, RenderMessage site msg
|
||||
)
|
||||
#endif
|
||||
=> [Filter a]
|
||||
-> [SelectOpt a]
|
||||
-> (a -> msg)
|
||||
@ -591,7 +578,6 @@ optionsPersist filts ords toDisplay = fmap mkOptionList $ do
|
||||
-- the entire @Entity@.
|
||||
--
|
||||
-- Since 1.3.2
|
||||
#if MIN_VERSION_persistent(2, 0, 0)
|
||||
optionsPersistKey
|
||||
:: (YesodPersist site
|
||||
, PersistEntity a
|
||||
@ -600,15 +586,6 @@ optionsPersistKey
|
||||
, RenderMessage site msg
|
||||
, YesodPersistBackend site ~ PersistEntityBackend a
|
||||
)
|
||||
#else
|
||||
optionsPersistKey
|
||||
:: (YesodPersist site
|
||||
, PersistEntity a
|
||||
, PersistQuery (YesodPersistBackend site (HandlerT site IO))
|
||||
, PathPiece (Key a)
|
||||
, RenderMessage site msg
|
||||
, PersistEntityBackend a ~ PersistMonadBackend (YesodDB site))
|
||||
#endif
|
||||
=> [Filter a]
|
||||
-> [SelectOpt a]
|
||||
-> (a -> msg)
|
||||
|
||||
@ -20,9 +20,6 @@ module Yesod.Persist.Core
|
||||
) where
|
||||
|
||||
import Database.Persist
|
||||
#if !MIN_VERSION_persistent(2, 0, 0)
|
||||
import Database.Persist.Sql (SqlPersistT, unSqlPersistT)
|
||||
#endif
|
||||
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
|
||||
|
||||
import Yesod.Core
|
||||
@ -34,24 +31,13 @@ import Control.Exception (throwIO)
|
||||
import Yesod.Core.Types (HandlerContents (HCError))
|
||||
import qualified Database.Persist.Sql as SQL
|
||||
|
||||
#if MIN_VERSION_persistent(2, 0, 0)
|
||||
unSqlPersistT :: a -> a
|
||||
unSqlPersistT = id
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_persistent(2, 0, 0)
|
||||
type YesodDB site = ReaderT (YesodPersistBackend site) (HandlerT site IO)
|
||||
#else
|
||||
type YesodDB site = YesodPersistBackend site (HandlerT site IO)
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_persistent(2, 0, 0)
|
||||
class Monad (YesodDB site) => YesodPersist site where
|
||||
type YesodPersistBackend site
|
||||
#else
|
||||
class Monad (YesodPersistBackend site (HandlerT site IO)) => YesodPersist site where
|
||||
type YesodPersistBackend site :: (* -> *) -> * -> *
|
||||
#endif
|
||||
runDB :: YesodDB site a -> HandlerT site IO a
|
||||
|
||||
-- | Helper for creating 'runDB'.
|
||||
@ -94,11 +80,7 @@ newtype DBRunner site = DBRunner
|
||||
-- | Helper for implementing 'getDBRunner'.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
#if MIN_VERSION_persistent(2, 0, 0)
|
||||
defaultGetDBRunner :: YesodPersistBackend site ~ SQL.SqlBackend
|
||||
#else
|
||||
defaultGetDBRunner :: YesodPersistBackend site ~ SqlPersistT
|
||||
#endif
|
||||
=> (site -> Pool SQL.Connection)
|
||||
-> HandlerT site IO (DBRunner site, HandlerT site IO ())
|
||||
defaultGetDBRunner getPool = do
|
||||
@ -142,20 +124,9 @@ respondSourceDB :: YesodPersistRunner site
|
||||
respondSourceDB ctype = respondSource ctype . runDBSource
|
||||
|
||||
-- | Get the given entity by ID, or return a 404 not found if it doesn't exist.
|
||||
#if MIN_VERSION_persistent(2, 0, 0)
|
||||
get404 :: (MonadIO m, PersistStore (PersistEntityBackend val), PersistEntity val)
|
||||
=> Key val
|
||||
-> ReaderT (PersistEntityBackend val) m val
|
||||
#else
|
||||
get404 :: ( PersistStore (t m)
|
||||
, PersistEntity val
|
||||
, Monad (t m)
|
||||
, m ~ HandlerT site IO
|
||||
, MonadTrans t
|
||||
, PersistMonadBackend (t m) ~ PersistEntityBackend val
|
||||
)
|
||||
=> Key val -> t m val
|
||||
#endif
|
||||
get404 key = do
|
||||
mres <- get key
|
||||
case mres of
|
||||
@ -164,20 +135,9 @@ get404 key = do
|
||||
|
||||
-- | Get the given entity by unique key, or return a 404 not found if it doesn't
|
||||
-- exist.
|
||||
#if MIN_VERSION_persistent(2, 0, 0)
|
||||
getBy404 :: (PersistUnique (PersistEntityBackend val), PersistEntity val, MonadIO m)
|
||||
=> Unique val
|
||||
-> ReaderT (PersistEntityBackend val) m (Entity val)
|
||||
#else
|
||||
getBy404 :: ( PersistUnique (t m)
|
||||
, PersistEntity val
|
||||
, m ~ HandlerT site IO
|
||||
, Monad (t m)
|
||||
, MonadTrans t
|
||||
, PersistEntityBackend val ~ PersistMonadBackend (t m)
|
||||
)
|
||||
=> Unique val -> t m (Entity val)
|
||||
#endif
|
||||
getBy404 key = do
|
||||
mres <- getBy key
|
||||
case mres of
|
||||
@ -188,11 +148,3 @@ getBy404 key = do
|
||||
-- GHC 7.4.2 that leads to segfaults. This is a workaround.
|
||||
notFound' :: MonadIO m => m a
|
||||
notFound' = liftIO $ throwIO $ HCError NotFound
|
||||
|
||||
#if !MIN_VERSION_persistent(2, 0, 0)
|
||||
instance MonadHandler m => MonadHandler (SqlPersistT m) where
|
||||
type HandlerSite (SqlPersistT m) = HandlerSite m
|
||||
liftHandlerT = lift . liftHandlerT
|
||||
instance MonadWidget m => MonadWidget (SqlPersistT m) where
|
||||
liftWidgetT = lift . liftWidgetT
|
||||
#endif
|
||||
|
||||
@ -29,11 +29,7 @@ mkYesod "App" [parseRoutes|
|
||||
|
||||
instance Yesod App
|
||||
instance YesodPersist App where
|
||||
#if MIN_VERSION_persistent(2, 0, 0)
|
||||
type YesodPersistBackend App = SqlBackend
|
||||
#else
|
||||
type YesodPersistBackend App = SqlPersistT
|
||||
#endif
|
||||
runDB = defaultRunDB appConfig appPool
|
||||
instance YesodPersistRunner App where
|
||||
getDBRunner = defaultGetDBRunner appPool
|
||||
|
||||
@ -90,11 +90,7 @@ instance Yesod master => YesodSubDispatch EmbeddedStatic (HandlerT master IO) wh
|
||||
resp = case pathInfo req of
|
||||
("res":_) -> stApp site req
|
||||
("widget":_) -> staticApp (widgetSettings site) req
|
||||
#if MIN_VERSION_wai(3,0,0)
|
||||
_ -> ($ responseLBS status404 [] "Not Found")
|
||||
#else
|
||||
_ -> return $ responseLBS status404 [] "Not Found"
|
||||
#endif
|
||||
|
||||
-- | Create the haskell variable for the link to the entry
|
||||
mkRoute :: ComputedEntry -> Q [Dec]
|
||||
|
||||
@ -107,11 +107,7 @@ prodEmbed e = do
|
||||
return $ ComputedEntry (ebHaskellName e) st link
|
||||
|
||||
toApp :: (Request -> IO Response) -> Application
|
||||
#if MIN_VERSION_wai(3, 0, 0)
|
||||
toApp f req g = f req >>= g
|
||||
#else
|
||||
toApp = id
|
||||
#endif
|
||||
|
||||
tryExtraDevelFiles :: [[T.Text] -> IO (Maybe (MimeType, BL.ByteString))] -> Application
|
||||
tryExtraDevelFiles = toApp . tryExtraDevelFiles'
|
||||
@ -133,19 +129,11 @@ tryExtraDevelFiles' (f:fs) r = do
|
||||
|
||||
-- | Helper to create the development application at runtime
|
||||
develApp :: StaticSettings -> [[T.Text] -> IO (Maybe (MimeType, BL.ByteString))] -> Application
|
||||
#if MIN_VERSION_wai(3, 0, 0)
|
||||
develApp settings extra req sendResponse = do
|
||||
staticApp settings {ssMaxAge = NoMaxAge} req $ \resp ->
|
||||
if statusCode (responseStatus resp) == 404
|
||||
then tryExtraDevelFiles extra req sendResponse
|
||||
else sendResponse resp
|
||||
#else
|
||||
develApp settings extra req = do
|
||||
resp <- staticApp settings {ssMaxAge = NoMaxAge} req
|
||||
if statusCode (responseStatus resp) == 404
|
||||
then tryExtraDevelFiles extra req
|
||||
else return resp
|
||||
#endif
|
||||
|
||||
-- | The type of 'addStaticContent'
|
||||
type AddStaticContent site = T.Text -> T.Text -> BL.ByteString
|
||||
|
||||
@ -47,11 +47,7 @@ webSockets :: (Y.MonadBaseControl IO m, Y.MonadHandler m) => WebSocketsT m () ->
|
||||
webSockets inner = do
|
||||
req <- Y.waiRequest
|
||||
when (WaiWS.isWebSocketsReq req) $
|
||||
#if MIN_VERSION_wai(3, 0, 0)
|
||||
Y.sendRawResponseNoConduit
|
||||
#else
|
||||
Y.sendRawResponse
|
||||
#endif
|
||||
$ \src sink -> control $ \runInIO -> WaiWS.runWebSockets
|
||||
WS.defaultConnectionOptions
|
||||
(WaiWS.getRequestHead req)
|
||||
|
||||
@ -76,12 +76,7 @@ defaultMainLog load getApp = do
|
||||
(toLogStr $ "Exception from Warp: " ++ show e)
|
||||
} app
|
||||
where
|
||||
shouldLog' =
|
||||
#if MIN_VERSION_warp(2,1,3)
|
||||
Warp.defaultShouldDisplayException
|
||||
#else
|
||||
const True
|
||||
#endif
|
||||
shouldLog' = Warp.defaultShouldDisplayException
|
||||
|
||||
-- | Run your application continously, listening for SIGINT and exiting
|
||||
-- when received
|
||||
|
||||
Loading…
Reference in New Issue
Block a user