diff --git a/Yesod/Core/Class/Handler.hs b/Yesod/Core/Class/Handler.hs --- a/Yesod/Core/Class/Handler.hs +++ b/Yesod/Core/Class/Handler.hs @@ -13,8 +13,8 @@ import Yesod.Core.Types import Data.Monoid (mempty) import Control.Monad (liftM) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Resource (MonadResource, MonadResourceBase, ExceptionT (..)) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (MonadResource, MonadResourceBase) import Control.Monad.Trans.Class (lift) import Data.Monoid (Monoid) import Data.Conduit.Internal (Pipe, ConduitM) @@ -61,9 +61,6 @@ 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, 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 diff --git a/Yesod/Core/Class/Yesod.hs b/Yesod/Core/Class/Yesod.hs --- a/Yesod/Core/Class/Yesod.hs +++ b/Yesod/Core/Class/Yesod.hs @@ -39,17 +39,8 @@ 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 +207,10 @@ -- -- 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 + loggerSet' <- newStdoutLoggerSet defaultBufSize (getter, _) <- clockDateCacher - return $! Logger loggerSet getter -#else - makeLogger _ = mkLogger True stdout -#endif + return $! Logger loggerSet' getter -- | Send a message to the @Logger@ provided by @getLogger@. -- @@ -541,7 +524,6 @@ Nothing -> Nothing Just j -> Just $ jelper j -#if MIN_VERSION_fast_logger(2, 0, 0) formatLogMessage :: IO ZonedDate -> Loc -> LogSource @@ -564,33 +546,6 @@ " @(" `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'. diff --git a/Yesod/Core/Content.hs b/Yesod/Core/Content.hs --- a/Yesod/Core/Content.hs +++ b/Yesod/Core/Content.hs @@ -63,12 +63,14 @@ 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 +#if MIN_VERSION_aeson(0, 7, 0) +import Data.Aeson.Encode (encodeToTextBuilder) +#else import Data.Aeson.Encode (fromValue) +#endif import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze import Data.Text.Lazy.Builder (toLazyText) import Yesod.Core.Types @@ -118,10 +120,8 @@ 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 @@ -247,7 +247,11 @@ toContent = flip ContentBuilder Nothing . Blaze.fromLazyText . toLazyText +#if MIN_VERSION_aeson(0, 7, 0) + . encodeToTextBuilder +#else . fromValue +#endif instance HasContentType J.Value where getContentType _ = typeJson diff --git a/Yesod/Core/Dispatch.hs b/Yesod/Core/Dispatch.hs --- a/Yesod/Core/Dispatch.hs +++ b/Yesod/Core/Dispatch.hs @@ -42,7 +42,7 @@ import Data.ByteString.Lazy.Char8 () -import Data.Text (Text, pack) +import Data.Text (Text) import Data.Monoid (mappend) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 @@ -92,13 +92,8 @@ 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" @@ -157,19 +152,10 @@ warp :: YesodDispatch site => Int -> site -> IO () warp port site = do logger <- makeLogger site - toWaiAppLogger logger site >>= Network.Wai.Handler.Warp.runSettings - Network.Wai.Handler.Warp.defaultSettings - { Network.Wai.Handler.Warp.settingsPort = port - {- FIXME - , Network.Wai.Handler.Warp.settingsServerName = S8.pack $ concat - [ "Warp/" - , Network.Wai.Handler.Warp.warpVersion - , " + Yesod/" - , showVersion Paths_yesod_core.version - , " (core)" - ] - -} - , Network.Wai.Handler.Warp.settingsOnException = const $ \e -> + toWaiAppLogger logger site >>= Network.Wai.Handler.Warp.runSettings ( + Network.Wai.Handler.Warp.setPort port $ + Network.Wai.Handler.Warp.setServerName serverValue $ + Network.Wai.Handler.Warp.setOnException (\_ e -> when (shouldLog' e) $ messageLoggerSource site @@ -177,27 +163,27 @@ $(qLocation >>= liftLoc) "yesod-core" LevelError - (toLogStr $ "Exception from Warp: " ++ show e) - } + (toLogStr $ "Exception from Warp: " ++ show e)) $ + Network.Wai.Handler.Warp.defaultSettings) where - shouldLog' = -#if MIN_VERSION_warp(2,1,3) - Network.Wai.Handler.Warp.defaultShouldDisplayException -#else - const True -#endif + shouldLog' = Network.Wai.Handler.Warp.defaultShouldDisplayException +serverValue :: S8.ByteString +serverValue = S8.pack $ concat + [ "Warp/" + , Network.Wai.Handler.Warp.warpVersion + , " + Yesod/" + , showVersion Paths_yesod_core.version + , " (core)" + ] + -- | A default set of middlewares. -- -- Since 1.2.0 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 diff --git a/Yesod/Core/Handler.hs b/Yesod/Core/Handler.hs --- a/Yesod/Core/Handler.hs +++ b/Yesod/Core/Handler.hs @@ -92,12 +92,8 @@ , 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 @@ -149,6 +145,7 @@ , getMessageRender -- * Per-request caching , cached + , cachedBy ) where import Data.Time (UTCTime, addUTCTime, @@ -191,10 +188,9 @@ import Yesod.Core.Internal.Util (formatRFC1123) import Text.Blaze.Html (preEscapedToMarkup, toHtml) -import Data.Dynamic (fromDynamic, toDyn) import qualified Data.IORef.Lifted as I import Data.Maybe (listToMaybe, mapMaybe) -import Data.Typeable (Typeable, typeOf) +import Data.Typeable (Typeable) import Web.PathPieces (PathPiece(..)) import Yesod.Core.Class.Handler import Yesod.Core.Types @@ -206,22 +202,13 @@ 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 ) +import qualified Yesod.Core.TypeCache as Cache get :: MonadHandler m => m GHState get = liftHandlerT $ HandlerT $ I.readIORef . handlerState @@ -257,41 +244,22 @@ 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 +343,7 @@ 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 @@ -388,6 +352,7 @@ return $ oldState { ghsRBC = Nothing , ghsIdent = 1 , ghsCache = mempty + , ghsCacheBy = mempty , ghsHeaders = mempty } -- xx From this point onwards, no references to oldHandlerData xx @@ -551,16 +516,12 @@ -> 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 +554,6 @@ 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 +569,7 @@ 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 +578,6 @@ 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 +589,6 @@ 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 @@ -905,34 +853,47 @@ l <- reqLangs `liftM` getRequest return $ renderMessage (rheSite env) l --- | Use a per-request cache to avoid performing the same action multiple --- times. Note that values are stored by their type. Therefore, you should use --- newtype wrappers to distinguish logically different types. +-- | Use a per-request cache to avoid performing the same action multiple times. +-- Values are stored by their type, the result of typeOf from Typeable. +-- Therefore, you should use different newtype wrappers at each cache site. -- +-- For example, yesod-auth uses an un-exported newtype, CachedMaybeAuth and exports functions that utilize it such as maybeAuth. +-- This means that another module can create its own newtype wrapper to cache the same type from a different action without any cache conflicts. +-- +-- See the original announcement: +-- -- Since 1.2.0 cached :: (MonadHandler m, Typeable a) => m a -> m a -cached f = do +cached action = do gs <- get - let cache = ghsCache gs - case clookup cache of - Just val -> return val - Nothing -> do - val <- f - put $ gs { ghsCache = cinsert val cache } - return val - where - clookup :: Typeable a => Cache -> Maybe a - clookup (Cache m) = - res - where - res = Map.lookup (typeOf $ fromJust res) m >>= fromDynamic - fromJust :: Maybe a -> a - fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated" + eres <- Cache.cached (ghsCache gs) action + case eres of + Right res -> return res + Left (newCache, res) -> do + put $ gs { ghsCache = newCache } + return res - cinsert :: Typeable a => a -> Cache -> Cache - cinsert v (Cache m) = Cache (Map.insert (typeOf v) (toDyn v) m) +-- | a per-request cache. just like 'cached'. +-- 'cached' can only cache a single value per type. +-- 'cachedBy' stores multiple values per type by usage of a ByteString key +-- +-- 'cached' is ideal to cache an action that has only one value of a type, such as the session's current user +-- 'cachedBy' is required if the action has parameters and can return multiple values per type. +-- You can turn those parameters into a ByteString cache key. +-- For example, caching a lookup of a Link by a token where multiple token lookups might be performed. +-- +-- Since 1.4.0 +cachedBy :: (MonadHandler m, Typeable a) => S.ByteString -> m a -> m a +cachedBy k action = do + gs <- get + eres <- Cache.cachedBy (ghsCacheBy gs) k action + case eres of + Right res -> return res + Left (newCache, res) -> do + put $ gs { ghsCacheBy = newCache } + return res -- | Get the list of supported languages supplied by the user. -- @@ -1126,22 +1087,12 @@ 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@. diff --git a/Yesod/Core/Internal/Request.hs b/Yesod/Core/Internal/Request.hs --- a/Yesod/Core/Internal/Request.hs +++ b/Yesod/Core/Internal/Request.hs @@ -39,7 +39,6 @@ import Data.Conduit.List (sourceList) import Data.Conduit.Binary (sourceFile, sinkFile) import Data.Word (Word64) -import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Resource (runResourceT, ResourceT) import Control.Exception (throwIO) import Yesod.Core.Types @@ -48,7 +47,6 @@ -- | 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 +61,6 @@ 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 diff --git a/Yesod/Core/Internal/Response.hs b/Yesod/Core/Internal/Response.hs --- a/Yesod/Core/Internal/Response.hs +++ b/Yesod/Core/Internal/Response.hs @@ -13,14 +13,12 @@ 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 Control.Monad.Trans.Resource (runInternalState, InternalState) import Network.Wai.Internal -import Control.Exception (finally) -#endif +#if !MIN_VERSION_base(4, 6, 0) import Prelude hiding (catch) +#endif import Web.Cookie (renderSetCookie) import Yesod.Core.Content import Yesod.Core.Types @@ -36,7 +34,6 @@ 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 @@ -46,7 +43,7 @@ -> IO ResponseReceived yarToResponse (YRWai a) _ _ _ _ sendResponse = sendResponse a yarToResponse (YRWaiApp app) _ _ req _ sendResponse = app req sendResponse -yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq req is sendResponse = do +yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq _req is sendResponse = do extraHeaders <- do let nsToken = maybe newSess @@ -76,82 +73,6 @@ s | 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 diff --git a/Yesod/Core/Internal/Run.hs b/Yesod/Core/Internal/Run.hs --- a/Yesod/Core/Internal/Run.hs +++ b/Yesod/Core/Internal/Run.hs @@ -10,7 +10,7 @@ import Yesod.Core.Internal.Response import Blaze.ByteString.Builder (toByteString) import Control.Applicative ((<$>)) -import Control.Exception (fromException, bracketOnError, evaluate) +import Control.Exception (fromException, evaluate) import qualified Control.Exception as E import Control.Exception.Lifted (catch) import Control.Monad (mplus) @@ -34,12 +34,9 @@ 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 +#if !MIN_VERSION_base(4, 6, 0) 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) @@ -49,8 +46,7 @@ import Yesod.Core.Internal.Request (parseWaiRequest, tooLargeResponse) import Yesod.Routes.Class (Route, renderRoute) -import Control.DeepSeq (($!!), NFData) -import Control.Monad (liftM) +import Control.DeepSeq (($!!)) returnDeepSessionMap :: Monad m => SessionMap -> m SessionMap #if MIN_VERSION_bytestring(0, 10, 0) @@ -79,6 +75,7 @@ , ghsRBC = Nothing , ghsIdent = 1 , ghsCache = mempty + , ghsCacheBy = mempty , ghsHeaders = mempty } let hd = HandlerData @@ -119,6 +116,7 @@ | otherwise = status' in return $ YRPlain status hs' ct c sess YRWai _ -> return yar + YRWaiApp _ -> return yar let sendFile' ct fp p = return $ YRPlain H.status200 headers ct (ContentFile fp p) finalSession contents1 <- evaluate contents `E.catch` \e -> return @@ -220,24 +218,16 @@ , 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 + , requestHeaderRange = Nothing } fakeRequest = YesodRequest @@ -258,13 +248,8 @@ -> 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 +276,11 @@ 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' diff --git a/Yesod/Core/Json.hs b/Yesod/Core/Json.hs --- a/Yesod/Core/Json.hs +++ b/Yesod/Core/Json.hs @@ -29,7 +29,6 @@ import Yesod.Core.Handler (HandlerT, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep) import Control.Monad.Trans.Writer (Writer) -import Control.Monad.Trans.Resource (runExceptionT) import Data.Monoid (Endo) import Yesod.Core.Content (TypedContent) import Yesod.Core.Types (reqAccept) @@ -95,11 +94,7 @@ -- /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 diff --git a/Yesod/Core/TypeCache.hs b/Yesod/Core/TypeCache.hs new file mode 100644 --- /dev/null +++ b/Yesod/Core/TypeCache.hs @@ -0,0 +1,83 @@ +-- | a module for caching a monadic action based on its return type +-- +-- The cache is a HashMap where the key uses the TypeReP from Typeable. +-- The value stored is toDyn from Dynamic to support arbitrary value types in the same Map. +-- +-- un-exported newtype wrappers should be used to maintain unique keys in the cache. +-- Note that a TypeRep is unique to a module in a package, so types from different modules will not conflict if they have the same name. +-- +-- used in 'Yesod.Core.Handler.cached' and 'Yesod.Core.Handler.cachedBy' +module Yesod.Core.TypeCache (cached, cachedBy, TypeMap, KeyedTypeMap) where + +import Prelude hiding (lookup) +import Data.Typeable (Typeable, TypeRep, typeOf) +import Data.HashMap.Strict +import Data.ByteString (ByteString) +import Data.Dynamic (Dynamic, toDyn, fromDynamic) + +type TypeMap = HashMap TypeRep Dynamic +type KeyedTypeMap = HashMap (TypeRep, ByteString) Dynamic + +-- | avoid performing the same action multiple times. +-- Values are stored by their TypeRep from Typeable. +-- Therefore, you should use un-exported newtype wrappers for each cache. +-- +-- For example, yesod-auth uses an un-exported newtype, CachedMaybeAuth and exports functions that utilize it such as maybeAuth. +-- This means that another module can create its own newtype wrapper to cache the same type from a different action without any cache conflicts. +-- +-- In Yesod, this is used for a request-local cache that is cleared at the end of every request. +-- See the original announcement: +-- +-- Since 1.4.0 +cached :: (Monad m, Typeable a) + => TypeMap + -> m a + -> m (Either (TypeMap, a) a) -- ^ Left is a cache miss, Right is a hit +cached cache action = case clookup cache of + Just val -> return $ Right val + Nothing -> do + val <- action + return $ Left (cinsert val cache, val) + where + clookup :: Typeable a => TypeMap -> Maybe a + clookup c = + res + where + res = lookup (typeOf $ fromJust res) c >>= fromDynamic + fromJust :: Maybe a -> a + fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated" + + cinsert :: Typeable a => a -> TypeMap -> TypeMap + cinsert v = insert (typeOf v) (toDyn v) + +-- | similar to 'cached'. +-- 'cached' can only cache a single value per type. +-- 'cachedBy' stores multiple values per type by indexing on a ByteString key +-- +-- 'cached' is ideal to cache an action that has only one value of a type, such as the session's current user +-- 'cachedBy' is required if the action has parameters and can return multiple values per type. +-- You can turn those parameters into a ByteString cache key. +-- For example, caching a lookup of a Link by a token where multiple token lookups might be performed. +-- +-- Since 1.4.0 +cachedBy :: (Monad m, Typeable a) + => KeyedTypeMap + -> ByteString + -> m a + -> m (Either (KeyedTypeMap, a) a) -- ^ Left is a cache miss, Right is a hit +cachedBy cache k action = case clookup k cache of + Just val -> return $ Right val + Nothing -> do + val <- action + return $ Left (cinsert k val cache, val) + where + clookup :: Typeable a => ByteString -> KeyedTypeMap -> Maybe a + clookup key c = + res + where + res = lookup (typeOf $ fromJust res, key) c >>= fromDynamic + fromJust :: Maybe a -> a + fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated" + + cinsert :: Typeable a => ByteString -> a -> KeyedTypeMap -> KeyedTypeMap + cinsert key v = insert (typeOf v, key) (toDyn v) diff --git a/Yesod/Core/Types.hs b/Yesod/Core/Types.hs --- a/Yesod/Core/Types.hs +++ b/Yesod/Core/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances #-} @@ -5,7 +6,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE CPP #-} module Yesod.Core.Types where import qualified Blaze.ByteString.Builder as BBuilder @@ -17,21 +17,15 @@ 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) -import Data.Dynamic (Dynamic) import Data.IORef (IORef) import Data.Map (Map, unionWith) import qualified Data.Map as Map @@ -45,19 +39,14 @@ import qualified Data.Text.Lazy.Builder as TBuilder import Data.Time (UTCTime) import Data.Typeable (Typeable) -import Data.Typeable (TypeRep) import Language.Haskell.TH.Syntax (Loc) import qualified Network.HTTP.Types as H 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) @@ -66,11 +55,12 @@ import Control.Monad.Trans.Class (MonadTrans (..)) import Yesod.Routes.Class (RenderRoute (..), ParseRoute (..)) import Control.Monad.Reader (MonadReader (..)) +#if !MIN_VERSION_base(4, 6, 0) import Prelude hiding (catch) +#endif import Control.DeepSeq (NFData (rnf)) -#if MIN_VERSION_conduit(1, 1, 0) import Data.Conduit.Lazy (MonadActive, monadActive) -#endif +import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap) -- Sessions type SessionMap = Map Text ByteString @@ -146,11 +136,7 @@ } 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. @@ -178,9 +164,6 @@ -> Maybe (HtmlUrl (Route master)) -- ^ widget of js to run on async completion -> (HtmlUrl (Route master)) -- ^ widget to insert at the bottom of -newtype Cache = Cache (Map TypeRep Dynamic) - deriving Monoid - type Texts = [Text] -- | Wrap up a normal WAI application as a Yesod subsite. @@ -239,7 +222,8 @@ { ghsSession :: SessionMap , ghsRBC :: Maybe RequestBodyContents , ghsIdent :: Int - , ghsCache :: Cache + , ghsCache :: TypeMap + , ghsCacheBy :: KeyedTypeMap , ghsHeaders :: Endo [Header] } @@ -423,14 +407,11 @@ 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 @@ 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 @@ 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 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 @@ loggerPutStr :: Logger -> LogStr -> IO () loggerPutStr (Logger ls _) = pushLogStr ls -#endif diff --git a/Yesod/Routes/Class.hs b/Yesod/Routes/Class.hs new file mode 100644 --- /dev/null +++ b/Yesod/Routes/Class.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +module Yesod.Routes.Class + ( RenderRoute (..) + , ParseRoute (..) + , RouteAttrs (..) + ) where + +import Data.Text (Text) +import Data.Set (Set) + +class Eq (Route a) => RenderRoute a where + -- | The type-safe URLs associated with a site argument. + data Route a + renderRoute :: Route a -> ([Text], [(Text, Text)]) + +class RenderRoute a => ParseRoute a where + parseRoute :: ([Text], [(Text, Text)]) -> Maybe (Route a) + +class RenderRoute a => RouteAttrs a where + routeAttrs :: Route a -> Set Text diff --git a/Yesod/Routes/Overlap.hs b/Yesod/Routes/Overlap.hs new file mode 100644 --- /dev/null +++ b/Yesod/Routes/Overlap.hs @@ -0,0 +1,88 @@ +-- | Check for overlapping routes. +module Yesod.Routes.Overlap + ( findOverlapNames + , Overlap (..) + ) where + +import Yesod.Routes.TH.Types +import Data.List (intercalate) + +data Flattened t = Flattened + { fNames :: [String] + , fPieces :: [Piece t] + , fHasSuffix :: Bool + , fCheck :: CheckOverlap + } + +flatten :: ResourceTree t -> [Flattened t] +flatten = + go id id True + where + go names pieces check (ResourceLeaf r) = return Flattened + { fNames = names [resourceName r] + , fPieces = pieces (resourcePieces r) + , fHasSuffix = hasSuffix $ ResourceLeaf r + , fCheck = check && resourceCheck r + } + go names pieces check (ResourceParent newname check' newpieces children) = + concatMap (go names' pieces' (check && check')) children + where + names' = names . (newname:) + pieces' = pieces . (newpieces ++) + +data Overlap t = Overlap + { overlapParents :: [String] -> [String] -- ^ parent resource trees + , overlap1 :: ResourceTree t + , overlap2 :: ResourceTree t + } + +data OverlapF = OverlapF + { _overlapF1 :: [String] + , _overlapF2 :: [String] + } + +overlaps :: [Piece t] -> [Piece t] -> Bool -> Bool -> Bool + +-- No pieces on either side, will overlap regardless of suffix +overlaps [] [] _ _ = True + +-- No pieces on the left, will overlap if the left side has a suffix +overlaps [] _ suffixX _ = suffixX + +-- Ditto for the right +overlaps _ [] _ suffixY = suffixY + +-- Compare the actual pieces +overlaps (pieceX:xs) (pieceY:ys) suffixX suffixY = + piecesOverlap pieceX pieceY && overlaps xs ys suffixX suffixY + +piecesOverlap :: Piece t -> Piece t -> Bool +-- Statics only match if they equal. Dynamics match with anything +piecesOverlap (Static x) (Static y) = x == y +piecesOverlap _ _ = True + +findOverlapNames :: [ResourceTree t] -> [(String, String)] +findOverlapNames = + map go . findOverlapsF . filter fCheck . concatMap Yesod.Routes.Overlap.flatten + where + go (OverlapF x y) = + (go' x, go' y) + where + go' = intercalate "/" + +findOverlapsF :: [Flattened t] -> [OverlapF] +findOverlapsF [] = [] +findOverlapsF (x:xs) = concatMap (findOverlapF x) xs ++ findOverlapsF xs + +findOverlapF :: Flattened t -> Flattened t -> [OverlapF] +findOverlapF x y + | overlaps (fPieces x) (fPieces y) (fHasSuffix x) (fHasSuffix y) = [OverlapF (fNames x) (fNames y)] + | otherwise = [] + +hasSuffix :: ResourceTree t -> Bool +hasSuffix (ResourceLeaf r) = + case resourceDispatch r of + Subsite{} -> True + Methods Just{} _ -> True + Methods Nothing _ -> False +hasSuffix ResourceParent{} = True diff --git a/Yesod/Routes/Parse.hs b/Yesod/Routes/Parse.hs new file mode 100644 --- /dev/null +++ b/Yesod/Routes/Parse.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PatternGuards #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter +module Yesod.Routes.Parse + ( parseRoutes + , parseRoutesFile + , parseRoutesNoCheck + , parseRoutesFileNoCheck + , parseType + , parseTypeTree + , TypeTree (..) + ) where + +import Language.Haskell.TH.Syntax +import Data.Char (isUpper) +import Language.Haskell.TH.Quote +import qualified System.IO as SIO +import Yesod.Routes.TH +import Yesod.Routes.Overlap (findOverlapNames) +import Data.List (foldl') +import Data.Maybe (mapMaybe) +import qualified Data.Set as Set + +-- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for +-- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the +-- checking. See documentation site for details on syntax. +parseRoutes :: QuasiQuoter +parseRoutes = QuasiQuoter { quoteExp = x } + where + x s = do + let res = resourcesFromString s + case findOverlapNames res of + [] -> lift res + z -> error $ unlines $ "Overlapping routes: " : map show z + +parseRoutesFile :: FilePath -> Q Exp +parseRoutesFile = parseRoutesFileWith parseRoutes + +parseRoutesFileNoCheck :: FilePath -> Q Exp +parseRoutesFileNoCheck = parseRoutesFileWith parseRoutesNoCheck + +parseRoutesFileWith :: QuasiQuoter -> FilePath -> Q Exp +parseRoutesFileWith qq fp = do + qAddDependentFile fp + s <- qRunIO $ readUtf8File fp + quoteExp qq s + +readUtf8File :: FilePath -> IO String +readUtf8File fp = do + h <- SIO.openFile fp SIO.ReadMode + SIO.hSetEncoding h SIO.utf8_bom + SIO.hGetContents h + +-- | Same as 'parseRoutes', but performs no overlap checking. +parseRoutesNoCheck :: QuasiQuoter +parseRoutesNoCheck = QuasiQuoter + { quoteExp = lift . resourcesFromString + } + +-- | Convert a multi-line string to a set of resources. See documentation for +-- the format of this string. This is a partial function which calls 'error' on +-- invalid input. +resourcesFromString :: String -> [ResourceTree String] +resourcesFromString = + fst . parse 0 . filter (not . all (== ' ')) . lines + where + parse _ [] = ([], []) + parse indent (thisLine:otherLines) + | length spaces < indent = ([], thisLine : otherLines) + | otherwise = (this others, remainder) + where + parseAttr ('!':x) = Just x + parseAttr _ = Nothing + + stripColonLast = + go id + where + go _ [] = Nothing + go front [x] + | null x = Nothing + | last x == ':' = Just $ front [init x] + | otherwise = Nothing + go front (x:xs) = go (front . (x:)) xs + + spaces = takeWhile (== ' ') thisLine + (others, remainder) = parse indent otherLines' + (this, otherLines') = + case takeWhile (/= "--") $ words thisLine of + (pattern:rest0) + | Just (constr:rest) <- stripColonLast rest0 + , Just attrs <- mapM parseAttr rest -> + let (children, otherLines'') = parse (length spaces + 1) otherLines + children' = addAttrs attrs children + (pieces, Nothing, check) = piecesFromStringCheck pattern + in ((ResourceParent constr check pieces children' :), otherLines'') + (pattern:constr:rest) -> + let (pieces, mmulti, check) = piecesFromStringCheck pattern + (attrs, rest') = takeAttrs rest + disp = dispatchFromString rest' mmulti + in ((ResourceLeaf (Resource constr pieces disp attrs check):), otherLines) + [] -> (id, otherLines) + _ -> error $ "Invalid resource line: " ++ thisLine + +piecesFromStringCheck :: String -> ([Piece String], Maybe String, Bool) +piecesFromStringCheck s0 = + (pieces, mmulti, check) + where + (s1, check1) = stripBang s0 + (pieces', mmulti') = piecesFromString $ drop1Slash s1 + pieces = map snd pieces' + mmulti = fmap snd mmulti' + check = check1 && all fst pieces' && maybe True fst mmulti' + + stripBang ('!':rest) = (rest, False) + stripBang x = (x, True) + +addAttrs :: [String] -> [ResourceTree String] -> [ResourceTree String] +addAttrs attrs = + map goTree + where + goTree (ResourceLeaf res) = ResourceLeaf (goRes res) + goTree (ResourceParent w x y z) = ResourceParent w x y (map goTree z) + + goRes res = + res { resourceAttrs = noDupes ++ resourceAttrs res } + where + usedKeys = Set.fromList $ map fst $ mapMaybe toPair $ resourceAttrs res + used attr = + case toPair attr of + Nothing -> False + Just (key, _) -> key `Set.member` usedKeys + noDupes = filter (not . used) attrs + + toPair s = + case break (== '=') s of + (x, '=':y) -> Just (x, y) + _ -> Nothing + +-- | Take attributes out of the list and put them in the first slot in the +-- result tuple. +takeAttrs :: [String] -> ([String], [String]) +takeAttrs = + go id id + where + go x y [] = (x [], y []) + go x y (('!':attr):rest) = go (x . (attr:)) y rest + go x y (z:rest) = go x (y . (z:)) rest + +dispatchFromString :: [String] -> Maybe String -> Dispatch String +dispatchFromString rest mmulti + | null rest = Methods mmulti [] + | all (all isUpper) rest = Methods mmulti rest +dispatchFromString [subTyp, subFun] Nothing = + Subsite subTyp subFun +dispatchFromString [_, _] Just{} = + error "Subsites cannot have a multipiece" +dispatchFromString rest _ = error $ "Invalid list of methods: " ++ show rest + +drop1Slash :: String -> String +drop1Slash ('/':x) = x +drop1Slash x = x + +piecesFromString :: String -> ([(CheckOverlap, Piece String)], Maybe (CheckOverlap, String)) +piecesFromString "" = ([], Nothing) +piecesFromString x = + case (this, rest) of + (Left typ, ([], Nothing)) -> ([], Just typ) + (Left _, _) -> error "Multipiece must be last piece" + (Right piece, (pieces, mtyp)) -> (piece:pieces, mtyp) + where + (y, z) = break (== '/') x + this = pieceFromString y + rest = piecesFromString $ drop 1 z + +parseType :: String -> Type +parseType orig = + maybe (error $ "Invalid type: " ++ show orig) ttToType $ parseTypeTree orig + +parseTypeTree :: String -> Maybe TypeTree +parseTypeTree orig = + toTypeTree pieces + where + pieces = filter (not . null) $ splitOn '-' $ addDashes orig + addDashes [] = [] + addDashes (x:xs) = + front $ addDashes xs + where + front rest + | x `elem` "()[]" = '-' : x : '-' : rest + | otherwise = x : rest + splitOn c s = + case y' of + _:y -> x : splitOn c y + [] -> [x] + where + (x, y') = break (== c) s + +data TypeTree = TTTerm String + | TTApp TypeTree TypeTree + | TTList TypeTree + deriving (Show, Eq) + +toTypeTree :: [String] -> Maybe TypeTree +toTypeTree orig = do + (x, []) <- gos orig + return x + where + go [] = Nothing + go ("(":xs) = do + (x, rest) <- gos xs + case rest of + ")":rest' -> Just (x, rest') + _ -> Nothing + go ("[":xs) = do + (x, rest) <- gos xs + case rest of + "]":rest' -> Just (TTList x, rest') + _ -> Nothing + go (x:xs) = Just (TTTerm x, xs) + + gos xs1 = do + (t, xs2) <- go xs1 + (ts, xs3) <- gos' id xs2 + Just (foldl' TTApp t ts, xs3) + + gos' front [] = Just (front [], []) + gos' front (x:xs) + | x `elem` words ") ]" = Just (front [], x:xs) + | otherwise = do + (t, xs') <- go $ x:xs + gos' (front . (t:)) xs' + +ttToType :: TypeTree -> Type +ttToType (TTTerm s) = ConT $ mkName s +ttToType (TTApp x y) = ttToType x `AppT` ttToType y +ttToType (TTList t) = ListT `AppT` ttToType t + +pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String) +pieceFromString ('#':'!':x) = Right $ (False, Dynamic x) +pieceFromString ('!':'#':x) = Right $ (False, Dynamic x) -- https://github.com/yesodweb/yesod/issues/652 +pieceFromString ('#':x) = Right $ (True, Dynamic x) + +pieceFromString ('*':'!':x) = Left (False, x) +pieceFromString ('+':'!':x) = Left (False, x) + +pieceFromString ('!':'*':x) = Left (False, x) +pieceFromString ('!':'+':x) = Left (False, x) + +pieceFromString ('*':x) = Left (True, x) +pieceFromString ('+':x) = Left (True, x) + +pieceFromString ('!':x) = Right $ (False, Static x) +pieceFromString x = Right $ (True, Static x) diff --git a/Yesod/Routes/TH.hs b/Yesod/Routes/TH.hs new file mode 100644 --- /dev/null +++ b/Yesod/Routes/TH.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TemplateHaskell #-} +module Yesod.Routes.TH + ( module Yesod.Routes.TH.Types + -- * Functions + , module Yesod.Routes.TH.RenderRoute + , module Yesod.Routes.TH.ParseRoute + , module Yesod.Routes.TH.RouteAttrs + -- ** Dispatch + , module Yesod.Routes.TH.Dispatch + ) where + +import Yesod.Routes.TH.Types +import Yesod.Routes.TH.RenderRoute +import Yesod.Routes.TH.ParseRoute +import Yesod.Routes.TH.RouteAttrs +import Yesod.Routes.TH.Dispatch diff --git a/Yesod/Routes/TH/Dispatch.hs b/Yesod/Routes/TH/Dispatch.hs new file mode 100644 --- /dev/null +++ b/Yesod/Routes/TH/Dispatch.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-} +module Yesod.Routes.TH.Dispatch + ( MkDispatchSettings (..) + , mkDispatchClause + , defaultGetHandler + ) where + +import Prelude hiding (exp) +import Language.Haskell.TH.Syntax +import Web.PathPieces +import Data.Maybe (catMaybes) +import Control.Monad (forM) +import Data.List (foldl') +import Control.Arrow (second) +import System.Random (randomRIO) +import Yesod.Routes.TH.Types +import Data.Char (toLower) + +data MkDispatchSettings = MkDispatchSettings + { mdsRunHandler :: Q Exp + , mdsSubDispatcher :: Q Exp + , mdsGetPathInfo :: Q Exp + , mdsSetPathInfo :: Q Exp + , mdsMethod :: Q Exp + , mds404 :: Q Exp + , mds405 :: Q Exp + , mdsGetHandler :: Maybe String -> String -> Q Exp + } + +data SDC = SDC + { clause404 :: Clause + , extraParams :: [Exp] + , extraCons :: [Exp] + , envExp :: Exp + , reqExp :: Exp + } + +-- | A simpler version of Yesod.Routes.TH.Dispatch.mkDispatchClause, based on +-- view patterns. +-- +-- Since 1.4.0 +mkDispatchClause :: MkDispatchSettings -> [ResourceTree a] -> Q Clause +mkDispatchClause MkDispatchSettings {..} resources = do + suffix <- qRunIO $ randomRIO (1000, 9999 :: Int) + envName <- newName $ "env" ++ show suffix + reqName <- newName $ "req" ++ show suffix + helperName <- newName $ "helper" ++ show suffix + + let envE = VarE envName + reqE = VarE reqName + helperE = VarE helperName + + clause404' <- mkClause404 envE reqE + getPathInfo <- mdsGetPathInfo + let pathInfo = getPathInfo `AppE` reqE + + let sdc = SDC + { clause404 = clause404' + , extraParams = [] + , extraCons = [] + , envExp = envE + , reqExp = reqE + } + clauses <- mapM (go sdc) resources + + return $ Clause + [VarP envName, VarP reqName] + (NormalB $ helperE `AppE` pathInfo) + [FunD helperName $ clauses ++ [clause404']] + where + handlePiece :: Piece a -> Q (Pat, Maybe Exp) + handlePiece (Static str) = return (LitP $ StringL str, Nothing) + handlePiece (Dynamic _) = do + x <- newName "dyn" + let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x]) + return (pat, Just $ VarE x) + + handlePieces :: [Piece a] -> Q ([Pat], [Exp]) + handlePieces = fmap (second catMaybes . unzip) . mapM handlePiece + + mkCon :: String -> [Exp] -> Exp + mkCon name = foldl' AppE (ConE $ mkName name) + + mkPathPat :: Pat -> [Pat] -> Pat + mkPathPat final = + foldr addPat final + where + addPat x y = ConP '(:) [x, y] + + go :: SDC -> ResourceTree a -> Q Clause + go sdc (ResourceParent name _check pieces children) = do + (pats, dyns) <- handlePieces pieces + let sdc' = sdc + { extraParams = extraParams sdc ++ dyns + , extraCons = extraCons sdc ++ [mkCon name dyns] + } + childClauses <- mapM (go sdc') children + + restName <- newName "rest" + let restE = VarE restName + restP = VarP restName + + helperName <- newName $ "helper" ++ name + let helperE = VarE helperName + + return $ Clause + [mkPathPat restP pats] + (NormalB $ helperE `AppE` restE) + [FunD helperName $ childClauses ++ [clause404 sdc]] + go SDC {..} (ResourceLeaf (Resource name pieces dispatch _ _check)) = do + (pats, dyns) <- handlePieces pieces + + (chooseMethod, finalPat) <- handleDispatch dispatch dyns + + return $ Clause + [mkPathPat finalPat pats] + (NormalB chooseMethod) + [] + where + handleDispatch :: Dispatch a -> [Exp] -> Q (Exp, Pat) + handleDispatch dispatch' dyns = + case dispatch' of + Methods multi methods -> do + (finalPat, mfinalE) <- + case multi of + Nothing -> return (ConP '[] [], Nothing) + Just _ -> do + multiName <- newName "multi" + let pat = ViewP (VarE 'fromPathMultiPiece) + (ConP 'Just [VarP multiName]) + return (pat, Just $ VarE multiName) + + let dynsMulti = + case mfinalE of + Nothing -> dyns + Just e -> dyns ++ [e] + route' = foldl' AppE (ConE (mkName name)) dynsMulti + route = foldr AppE route' extraCons + jroute = ConE 'Just `AppE` route + allDyns = extraParams ++ dynsMulti + mkRunExp mmethod = do + runHandlerE <- mdsRunHandler + handlerE' <- mdsGetHandler mmethod name + let handlerE = foldl' AppE handlerE' allDyns + return $ runHandlerE + `AppE` handlerE + `AppE` envExp + `AppE` jroute + `AppE` reqExp + + func <- + case methods of + [] -> mkRunExp Nothing + _ -> do + getMethod <- mdsMethod + let methodE = getMethod `AppE` reqExp + matches <- forM methods $ \method -> do + exp <- mkRunExp (Just method) + return $ Match (LitP $ StringL method) (NormalB exp) [] + match405 <- do + runHandlerE <- mdsRunHandler + handlerE <- mds405 + let exp = runHandlerE + `AppE` handlerE + `AppE` envExp + `AppE` jroute + `AppE` reqExp + return $ Match WildP (NormalB exp) [] + return $ CaseE methodE $ matches ++ [match405] + + return (func, finalPat) + Subsite _ getSub -> do + restPath <- newName "restPath" + setPathInfoE <- mdsSetPathInfo + subDispatcherE <- mdsSubDispatcher + runHandlerE <- mdsRunHandler + sub <- newName "sub" + let sub2 = LamE [VarP sub] + (foldl' (\a b -> a `AppE` b) (VarE (mkName getSub) `AppE` VarE sub) dyns) + let reqExp' = setPathInfoE `AppE` VarE restPath `AppE` reqExp + route' = foldl' AppE (ConE (mkName name)) dyns + route = foldr AppE route' extraCons + exp = subDispatcherE + `AppE` runHandlerE + `AppE` sub2 + `AppE` route + `AppE` envExp + `AppE` reqExp' + return (exp, VarP restPath) + + mkClause404 envE reqE = do + handler <- mds404 + runHandler <- mdsRunHandler + let exp = runHandler `AppE` handler `AppE` envE `AppE` ConE 'Nothing `AppE` reqE + return $ Clause [WildP] (NormalB exp) [] + +defaultGetHandler :: Maybe String -> String -> Q Exp +defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s +defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s diff --git a/Yesod/Routes/TH/ParseRoute.hs b/Yesod/Routes/TH/ParseRoute.hs new file mode 100644 --- /dev/null +++ b/Yesod/Routes/TH/ParseRoute.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE TemplateHaskell #-} +module Yesod.Routes.TH.ParseRoute + ( -- ** ParseRoute + mkParseRouteInstance + ) where + +import Yesod.Routes.TH.Types +import Language.Haskell.TH.Syntax +import Data.Text (Text) +import Yesod.Routes.Class +import Yesod.Routes.TH.Dispatch + +mkParseRouteInstance :: Type -> [ResourceTree a] -> Q Dec +mkParseRouteInstance typ ress = do + cls <- mkDispatchClause + MkDispatchSettings + { mdsRunHandler = [|\_ _ x _ -> x|] + , mds404 = [|error "mds404"|] + , mds405 = [|error "mds405"|] + , mdsGetPathInfo = [|fst|] + , mdsMethod = [|error "mdsMethod"|] + , mdsGetHandler = \_ _ -> [|error "mdsGetHandler"|] + , mdsSetPathInfo = [|\p (_, q) -> (p, q)|] + , mdsSubDispatcher = [|\_runHandler _getSub toMaster _env -> fmap toMaster . parseRoute|] + } + (map removeMethods ress) + helper <- newName "helper" + fixer <- [|(\f x -> f () x) :: (() -> ([Text], [(Text, Text)]) -> Maybe (Route a)) -> ([Text], [(Text, Text)]) -> Maybe (Route a)|] + return $ InstanceD [] (ConT ''ParseRoute `AppT` typ) + [ FunD 'parseRoute $ return $ Clause + [] + (NormalB $ fixer `AppE` VarE helper) + [FunD helper [cls]] + ] + where + -- We do this in order to ski the unnecessary method parsing + removeMethods (ResourceLeaf res) = ResourceLeaf $ removeMethodsLeaf res + removeMethods (ResourceParent w x y z) = ResourceParent w x y $ map removeMethods z + + removeMethodsLeaf res = res { resourceDispatch = fixDispatch $ resourceDispatch res } + + fixDispatch (Methods x _) = Methods x [] + fixDispatch x = x diff --git a/Yesod/Routes/TH/RenderRoute.hs b/Yesod/Routes/TH/RenderRoute.hs new file mode 100644 --- /dev/null +++ b/Yesod/Routes/TH/RenderRoute.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE TemplateHaskell #-} +module Yesod.Routes.TH.RenderRoute + ( -- ** RenderRoute + mkRenderRouteInstance + , mkRenderRouteInstance' + , mkRouteCons + , mkRenderRouteClauses + ) where + +import Yesod.Routes.TH.Types +import Language.Haskell.TH.Syntax +import Data.Maybe (maybeToList) +import Control.Monad (replicateM) +import Data.Text (pack) +import Web.PathPieces (PathPiece (..), PathMultiPiece (..)) +import Yesod.Routes.Class +import Data.Monoid (mconcat) + +-- | Generate the constructors of a route data type. +mkRouteCons :: [ResourceTree Type] -> ([Con], [Dec]) +mkRouteCons = + mconcat . map mkRouteCon + where + mkRouteCon (ResourceLeaf res) = + ([con], []) + where + con = NormalC (mkName $ resourceName res) + $ map (\x -> (NotStrict, x)) + $ concat [singles, multi, sub] + singles = concatMap toSingle $ resourcePieces res + toSingle Static{} = [] + toSingle (Dynamic typ) = [typ] + + multi = maybeToList $ resourceMulti res + + sub = + case resourceDispatch res of + Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ] + _ -> [] + mkRouteCon (ResourceParent name _check pieces children) = + ([con], dec : decs) + where + (cons, decs) = mkRouteCons children + con = NormalC (mkName name) + $ map (\x -> (NotStrict, x)) + $ concat [singles, [ConT $ mkName name]] + dec = DataD [] (mkName name) [] cons [''Show, ''Read, ''Eq] + + singles = concatMap toSingle pieces + toSingle Static{} = [] + toSingle (Dynamic typ) = [typ] + +-- | Clauses for the 'renderRoute' method. +mkRenderRouteClauses :: [ResourceTree Type] -> Q [Clause] +mkRenderRouteClauses = + mapM go + where + isDynamic Dynamic{} = True + isDynamic _ = False + + go (ResourceParent name _check pieces children) = do + let cnt = length $ filter isDynamic pieces + dyns <- replicateM cnt $ newName "dyn" + child <- newName "child" + let pat = ConP (mkName name) $ map VarP $ dyns ++ [child] + + pack' <- [|pack|] + tsp <- [|toPathPiece|] + let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp pieces dyns + + childRender <- newName "childRender" + let rr = VarE childRender + childClauses <- mkRenderRouteClauses children + + a <- newName "a" + b <- newName "b" + + colon <- [|(:)|] + let cons y ys = InfixE (Just y) colon (Just ys) + let pieces' = foldr cons (VarE a) piecesSingle + + let body = LamE [TupP [VarP a, VarP b]] (TupE [pieces', VarE b]) `AppE` (rr `AppE` VarE child) + + return $ Clause [pat] (NormalB body) [FunD childRender childClauses] + + go (ResourceLeaf res) = do + let cnt = length (filter isDynamic $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res) + dyns <- replicateM cnt $ newName "dyn" + sub <- + case resourceDispatch res of + Subsite{} -> fmap return $ newName "sub" + _ -> return [] + let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub + + pack' <- [|pack|] + tsp <- [|toPathPiece|] + let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns + + piecesMulti <- + case resourceMulti res of + Nothing -> return $ ListE [] + Just{} -> do + tmp <- [|toPathMultiPiece|] + return $ tmp `AppE` VarE (last dyns) + + body <- + case sub of + [x] -> do + rr <- [|renderRoute|] + a <- newName "a" + b <- newName "b" + + colon <- [|(:)|] + let cons y ys = InfixE (Just y) colon (Just ys) + let pieces = foldr cons (VarE a) piecesSingle + + return $ LamE [TupP [VarP a, VarP b]] (TupE [pieces, VarE b]) `AppE` (rr `AppE` VarE x) + _ -> do + colon <- [|(:)|] + let cons a b = InfixE (Just a) colon (Just b) + return $ TupE [foldr cons piecesMulti piecesSingle, ListE []] + + return $ Clause [pat] (NormalB body) [] + + mkPieces _ _ [] _ = [] + mkPieces toText tsp (Static s:ps) dyns = toText s : mkPieces toText tsp ps dyns + mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = tsp `AppE` VarE d : mkPieces toText tsp ps dyns + mkPieces _ _ ((Dynamic _) : _) [] = error "mkPieces 120" + +-- | Generate the 'RenderRoute' instance. +-- +-- This includes both the 'Route' associated type and the +-- 'renderRoute' method. This function uses both 'mkRouteCons' and +-- 'mkRenderRouteClasses'. +mkRenderRouteInstance :: Type -> [ResourceTree Type] -> Q [Dec] +mkRenderRouteInstance = mkRenderRouteInstance' [] + +-- | A more general version of 'mkRenderRouteInstance' which takes an +-- additional context. + +mkRenderRouteInstance' :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec] +mkRenderRouteInstance' cxt typ ress = do + cls <- mkRenderRouteClauses ress + let (cons, decs) = mkRouteCons ress + return $ InstanceD cxt (ConT ''RenderRoute `AppT` typ) + [ DataInstD [] ''Route [typ] cons clazzes + , FunD (mkName "renderRoute") cls + ] : decs + where + clazzes = [''Show, ''Eq, ''Read] diff --git a/Yesod/Routes/TH/RouteAttrs.hs b/Yesod/Routes/TH/RouteAttrs.hs new file mode 100644 --- /dev/null +++ b/Yesod/Routes/TH/RouteAttrs.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} +module Yesod.Routes.TH.RouteAttrs + ( mkRouteAttrsInstance + ) where + +import Yesod.Routes.TH.Types +import Yesod.Routes.Class +import Language.Haskell.TH.Syntax +import Data.Set (fromList) +import Data.Text (pack) + +mkRouteAttrsInstance :: Type -> [ResourceTree a] -> Q Dec +mkRouteAttrsInstance typ ress = do + clauses <- mapM (goTree id) ress + return $ InstanceD [] (ConT ''RouteAttrs `AppT` typ) + [ FunD 'routeAttrs $ concat clauses + ] + +goTree :: (Pat -> Pat) -> ResourceTree a -> Q [Clause] +goTree front (ResourceLeaf res) = fmap return $ goRes front res +goTree front (ResourceParent name _check pieces trees) = + fmap concat $ mapM (goTree front') trees + where + ignored = ((replicate toIgnore WildP ++) . return) + toIgnore = length $ filter isDynamic pieces + isDynamic Dynamic{} = True + isDynamic Static{} = False + front' = front . ConP (mkName name) . ignored + +goRes :: (Pat -> Pat) -> Resource a -> Q Clause +goRes front Resource {..} = + return $ Clause + [front $ RecP (mkName resourceName) []] + (NormalB $ VarE 'fromList `AppE` ListE (map toText resourceAttrs)) + [] + where + toText s = VarE 'pack `AppE` LitE (StringL s) diff --git a/Yesod/Routes/TH/Types.hs b/Yesod/Routes/TH/Types.hs new file mode 100644 --- /dev/null +++ b/Yesod/Routes/TH/Types.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TemplateHaskell #-} +module Yesod.Routes.TH.Types + ( -- * Data types + Resource (..) + , ResourceTree (..) + , Piece (..) + , Dispatch (..) + , CheckOverlap + , FlatResource (..) + -- ** Helper functions + , resourceMulti + , resourceTreePieces + , resourceTreeName + , flatten + ) where + +import Language.Haskell.TH.Syntax + +data ResourceTree typ + = ResourceLeaf (Resource typ) + | ResourceParent String CheckOverlap [Piece typ] [ResourceTree typ] + deriving Functor + +resourceTreePieces :: ResourceTree typ -> [Piece typ] +resourceTreePieces (ResourceLeaf r) = resourcePieces r +resourceTreePieces (ResourceParent _ _ x _) = x + +resourceTreeName :: ResourceTree typ -> String +resourceTreeName (ResourceLeaf r) = resourceName r +resourceTreeName (ResourceParent x _ _ _) = x + +instance Lift t => Lift (ResourceTree t) where + lift (ResourceLeaf r) = [|ResourceLeaf $(lift r)|] + lift (ResourceParent a b c d) = [|ResourceParent $(lift a) $(lift b) $(lift c) $(lift d)|] + +data Resource typ = Resource + { resourceName :: String + , resourcePieces :: [Piece typ] + , resourceDispatch :: Dispatch typ + , resourceAttrs :: [String] + , resourceCheck :: CheckOverlap + } + deriving (Show, Functor) + +type CheckOverlap = Bool + +instance Lift t => Lift (Resource t) where + lift (Resource a b c d e) = [|Resource a b c d e|] + +data Piece typ = Static String | Dynamic typ + deriving Show + +instance Functor Piece where + fmap _ (Static s) = (Static s) + fmap f (Dynamic t) = Dynamic (f t) + +instance Lift t => Lift (Piece t) where + lift (Static s) = [|Static $(lift s)|] + lift (Dynamic t) = [|Dynamic $(lift t)|] + +data Dispatch typ = + Methods + { methodsMulti :: Maybe typ -- ^ type of the multi piece at the end + , methodsMethods :: [String] -- ^ supported request methods + } + | Subsite + { subsiteType :: typ + , subsiteFunc :: String + } + deriving Show + +instance Functor Dispatch where + fmap f (Methods a b) = Methods (fmap f a) b + fmap f (Subsite a b) = Subsite (f a) b + +instance Lift t => Lift (Dispatch t) where + lift (Methods Nothing b) = [|Methods Nothing $(lift b)|] + lift (Methods (Just t) b) = [|Methods (Just $(lift t)) $(lift b)|] + lift (Subsite t b) = [|Subsite $(lift t) $(lift b)|] + +resourceMulti :: Resource typ -> Maybe typ +resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t +resourceMulti _ = Nothing + +data FlatResource a = FlatResource + { frParentPieces :: [(String, [Piece a])] + , frName :: String + , frPieces :: [Piece a] + , frDispatch :: Dispatch a + , frCheck :: Bool + } + +flatten :: [ResourceTree a] -> [FlatResource a] +flatten = + concatMap (go id True) + where + go front check' (ResourceLeaf (Resource a b c _ check)) = [FlatResource (front []) a b c (check' && check)] + go front check' (ResourceParent name check pieces children) = + concatMap (go (front . ((name, pieces):)) (check && check')) children diff --git a/test/RouteSpec.hs b/test/RouteSpec.hs new file mode 100644 --- /dev/null +++ b/test/RouteSpec.hs @@ -0,0 +1,336 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns#-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -ddump-splices #-} +import Test.Hspec +import Test.HUnit ((@?=)) +import Data.Text (Text, pack, unpack, singleton) +import Yesod.Routes.Class hiding (Route) +import qualified Yesod.Routes.Class as YRC +import Yesod.Routes.Parse (parseRoutesNoCheck, parseTypeTree, TypeTree (..)) +import Yesod.Routes.Overlap (findOverlapNames) +import Yesod.Routes.TH hiding (Dispatch) +import Language.Haskell.TH.Syntax +import Hierarchy +import qualified Data.ByteString.Char8 as S8 +import qualified Data.Set as Set + +data MyApp = MyApp + +data MySub = MySub +instance RenderRoute MySub where + data +#if MIN_VERSION_base(4,5,0) + Route +#else + YRC.Route +#endif + MySub = MySubRoute ([Text], [(Text, Text)]) + deriving (Show, Eq, Read) + renderRoute (MySubRoute x) = x +instance ParseRoute MySub where + parseRoute = Just . MySubRoute + +getMySub :: MyApp -> MySub +getMySub MyApp = MySub + +data MySubParam = MySubParam Int +instance RenderRoute MySubParam where + data +#if MIN_VERSION_base(4,5,0) + Route +#else + YRC.Route +#endif + MySubParam = ParamRoute Char + deriving (Show, Eq, Read) + renderRoute (ParamRoute x) = ([singleton x], []) +instance ParseRoute MySubParam where + parseRoute ([unpack -> [x]], _) = Just $ ParamRoute x + parseRoute _ = Nothing + +getMySubParam :: MyApp -> Int -> MySubParam +getMySubParam _ = MySubParam + +do + texts <- [t|[Text]|] + let resLeaves = map ResourceLeaf + [ Resource "RootR" [] (Methods Nothing ["GET"]) ["foo", "bar"] True + , Resource "BlogPostR" [Static "blog", Dynamic $ ConT ''Text] (Methods Nothing ["GET", "POST"]) [] True + , Resource "WikiR" [Static "wiki"] (Methods (Just texts) []) [] True + , Resource "SubsiteR" [Static "subsite"] (Subsite (ConT ''MySub) "getMySub") [] True + , Resource "SubparamR" [Static "subparam", Dynamic $ ConT ''Int] (Subsite (ConT ''MySubParam) "getMySubParam") [] True + ] + resParent = ResourceParent + "ParentR" + True + [ Static "foo" + , Dynamic $ ConT ''Text + ] + [ ResourceLeaf $ Resource "ChildR" [] (Methods Nothing ["GET"]) ["child"] True + ] + ress = resParent : resLeaves + rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress + rainst <- mkRouteAttrsInstance (ConT ''MyApp) ress + prinst <- mkParseRouteInstance (ConT ''MyApp) ress + dispatch <- mkDispatchClause MkDispatchSettings + { mdsRunHandler = [|runHandler|] + , mdsSubDispatcher = [|subDispatch dispatcher|] + , mdsGetPathInfo = [|fst|] + , mdsMethod = [|snd|] + , mdsSetPathInfo = [|\p (_, m) -> (p, m)|] + , mds404 = [|pack "404"|] + , mds405 = [|pack "405"|] + , mdsGetHandler = defaultGetHandler + } ress + return + $ InstanceD + [] + (ConT ''Dispatcher + `AppT` ConT ''MyApp + `AppT` ConT ''MyApp) + [FunD (mkName "dispatcher") [dispatch]] + : prinst + : rainst + : rrinst + +instance Dispatcher MySub master where + dispatcher env (pieces, _method) = + ( pack $ "subsite: " ++ show pieces + , Just $ envToMaster env route + ) + where + route = MySubRoute (pieces, []) + +instance Dispatcher MySubParam master where + dispatcher env (pieces, method) = + case map unpack pieces of + [[c]] -> + let route = ParamRoute c + toMaster = envToMaster env + MySubParam i = envSub env + in ( pack $ "subparam " ++ show i ++ ' ' : [c] + , Just $ toMaster route + ) + _ -> (pack "404", Nothing) + +{- +thDispatchAlias + :: (master ~ MyApp, sub ~ MyApp, handler ~ String, app ~ (String, Maybe (YRC.Route MyApp))) + => master + -> sub + -> (YRC.Route sub -> YRC.Route master) + -> app -- ^ 404 page + -> handler -- ^ 405 page + -> Text -- ^ method + -> [Text] + -> app +--thDispatchAlias = thDispatch +thDispatchAlias master sub toMaster app404 handler405 method0 pieces0 = + case dispatch pieces0 of + Just f -> f master sub toMaster app404 handler405 method0 + Nothing -> app404 + where + dispatch = toDispatch + [ Route [] False $ \pieces -> + case pieces of + [] -> do + Just $ \master' sub' toMaster' _app404' handler405' method -> + let handler = + case Map.lookup method methodsRootR of + Just f -> f + Nothing -> handler405' + in runHandler handler master' sub' RootR toMaster' + _ -> error "Invariant violated" + , Route [D.Static "blog", D.Dynamic] False $ \pieces -> + case pieces of + [_, x2] -> do + y2 <- fromPathPiece x2 + Just $ \master' sub' toMaster' _app404' handler405' method -> + let handler = + case Map.lookup method methodsBlogPostR of + Just f -> f y2 + Nothing -> handler405' + in runHandler handler master' sub' (BlogPostR y2) toMaster' + _ -> error "Invariant violated" + , Route [D.Static "wiki"] True $ \pieces -> + case pieces of + _:x2 -> do + y2 <- fromPathMultiPiece x2 + Just $ \master' sub' toMaster' _app404' _handler405' _method -> + let handler = handleWikiR y2 + in runHandler handler master' sub' (WikiR y2) toMaster' + _ -> error "Invariant violated" + , Route [D.Static "subsite"] True $ \pieces -> + case pieces of + _:x2 -> do + Just $ \master' sub' toMaster' app404' handler405' method -> + dispatcher master' (getMySub sub') (toMaster' . SubsiteR) app404' handler405' method x2 + _ -> error "Invariant violated" + , Route [D.Static "subparam", D.Dynamic] True $ \pieces -> + case pieces of + _:x2:x3 -> do + y2 <- fromPathPiece x2 + Just $ \master' sub' toMaster' app404' handler405' method -> + dispatcher master' (getMySubParam sub' y2) (toMaster' . SubparamR y2) app404' handler405' method x3 + _ -> error "Invariant violated" + ] + methodsRootR = Map.fromList [("GET", getRootR)] + methodsBlogPostR = Map.fromList [("GET", getBlogPostR), ("POST", postBlogPostR)] +-} + +main :: IO () +main = hspec $ do + describe "RenderRoute instance" $ do + it "renders root correctly" $ renderRoute RootR @?= ([], []) + it "renders blog post correctly" $ renderRoute (BlogPostR $ pack "foo") @?= (map pack ["blog", "foo"], []) + it "renders wiki correctly" $ renderRoute (WikiR $ map pack ["foo", "bar"]) @?= (map pack ["wiki", "foo", "bar"], []) + it "renders subsite correctly" $ renderRoute (SubsiteR $ MySubRoute (map pack ["foo", "bar"], [(pack "baz", pack "bin")])) + @?= (map pack ["subsite", "foo", "bar"], [(pack "baz", pack "bin")]) + it "renders subsite param correctly" $ renderRoute (SubparamR 6 $ ParamRoute 'c') + @?= (map pack ["subparam", "6", "c"], []) + + describe "thDispatch" $ do + let disp m ps = dispatcher + (Env + { envToMaster = id + , envMaster = MyApp + , envSub = MyApp + }) + (map pack ps, S8.pack m) + it "routes to root" $ disp "GET" [] @?= (pack "this is the root", Just RootR) + it "POST root is 405" $ disp "POST" [] @?= (pack "405", Just RootR) + it "invalid page is a 404" $ disp "GET" ["not-found"] @?= (pack "404", Nothing :: Maybe (YRC.Route MyApp)) + it "routes to blog post" $ disp "GET" ["blog", "somepost"] + @?= (pack "some blog post: somepost", Just $ BlogPostR $ pack "somepost") + it "routes to blog post, POST method" $ disp "POST" ["blog", "somepost2"] + @?= (pack "POST some blog post: somepost2", Just $ BlogPostR $ pack "somepost2") + it "routes to wiki" $ disp "DELETE" ["wiki", "foo", "bar"] + @?= (pack "the wiki: [\"foo\",\"bar\"]", Just $ WikiR $ map pack ["foo", "bar"]) + it "routes to subsite" $ disp "PUT" ["subsite", "baz"] + @?= (pack "subsite: [\"baz\"]", Just $ SubsiteR $ MySubRoute ([pack "baz"], [])) + it "routes to subparam" $ disp "PUT" ["subparam", "6", "q"] + @?= (pack "subparam 6 q", Just $ SubparamR 6 $ ParamRoute 'q') + + describe "parsing" $ do + it "subsites work" $ do + parseRoute ([pack "subsite", pack "foo"], [(pack "bar", pack "baz")]) @?= + Just (SubsiteR $ MySubRoute ([pack "foo"], [(pack "bar", pack "baz")])) + + describe "overlap checking" $ do + it "catches overlapping statics" $ do + let routes = [parseRoutesNoCheck| +/foo Foo1 +/foo Foo2 +|] + findOverlapNames routes @?= [("Foo1", "Foo2")] + it "catches overlapping dynamics" $ do + let routes = [parseRoutesNoCheck| +/#Int Foo1 +/#String Foo2 +|] + findOverlapNames routes @?= [("Foo1", "Foo2")] + it "catches overlapping statics and dynamics" $ do + let routes = [parseRoutesNoCheck| +/foo Foo1 +/#String Foo2 +|] + findOverlapNames routes @?= [("Foo1", "Foo2")] + it "catches overlapping multi" $ do + let routes = [parseRoutesNoCheck| +/foo Foo1 +/##*Strings Foo2 +|] + findOverlapNames routes @?= [("Foo1", "Foo2")] + it "catches overlapping subsite" $ do + let routes = [parseRoutesNoCheck| +/foo Foo1 +/foo Foo2 Subsite getSubsite +|] + findOverlapNames routes @?= [("Foo1", "Foo2")] + it "no false positives" $ do + let routes = [parseRoutesNoCheck| +/foo Foo1 +/bar/#String Foo2 +|] + findOverlapNames routes @?= [] + it "obeys ignore rules" $ do + let routes = [parseRoutesNoCheck| +/foo Foo1 +/#!String Foo2 +/!foo Foo3 +|] + findOverlapNames routes @?= [] + it "obeys multipiece ignore rules #779" $ do + let routes = [parseRoutesNoCheck| +/foo Foo1 +/+![String] Foo2 +|] + findOverlapNames routes @?= [] + it "ignore rules for entire route #779" $ do + let routes = [parseRoutesNoCheck| +/foo Foo1 +!/+[String] Foo2 +!/#String Foo3 +!/foo Foo4 +|] + findOverlapNames routes @?= [] + it "ignore rules for hierarchy" $ do + let routes = [parseRoutesNoCheck| +/+[String] Foo1 +!/foo Foo2: + /foo Foo3 +/foo Foo4: + /!#foo Foo5 +|] + findOverlapNames routes @?= [] + it "proper boolean logic" $ do + let routes = [parseRoutesNoCheck| +/foo/bar Foo1 +/foo/baz Foo2 +/bar/baz Foo3 +|] + findOverlapNames routes @?= [] + describe "routeAttrs" $ do + it "works" $ do + routeAttrs RootR @?= Set.fromList [pack "foo", pack "bar"] + it "hierarchy" $ do + routeAttrs (ParentR (pack "ignored") ChildR) @?= Set.singleton (pack "child") + hierarchy + describe "parseRouteTyoe" $ do + let success s t = it s $ parseTypeTree s @?= Just t + failure s = it s $ parseTypeTree s @?= Nothing + success "Int" $ TTTerm "Int" + success "(Int)" $ TTTerm "Int" + failure "(Int" + failure "(Int))" + failure "[Int" + failure "[Int]]" + success "[Int]" $ TTList $ TTTerm "Int" + success "Foo-Bar" $ TTApp (TTTerm "Foo") (TTTerm "Bar") + success "Foo-Bar-Baz" $ TTApp (TTTerm "Foo") (TTTerm "Bar") `TTApp` TTTerm "Baz" + +getRootR :: Text +getRootR = pack "this is the root" + +getBlogPostR :: Text -> String +getBlogPostR t = "some blog post: " ++ unpack t + +postBlogPostR :: Text -> Text +postBlogPostR t = pack $ "POST some blog post: " ++ unpack t + +handleWikiR :: [Text] -> String +handleWikiR ts = "the wiki: " ++ show ts + +getChildR :: Text -> Text +getChildR = id diff --git a/test/YesodCoreTest.hs b/test/YesodCoreTest.hs --- a/test/YesodCoreTest.hs +++ b/test/YesodCoreTest.hs @@ -15,9 +15,7 @@ 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 @@ JsLoader.specs RequestBodySize.specs Json.specs -#if MIN_VERSION_wai(2, 1, 0) RawResponse.specs -#endif Streaming.specs Reps.specs Auth.specs diff --git a/test/YesodCoreTest/Cache.hs b/test/YesodCoreTest/Cache.hs --- a/test/YesodCoreTest/Cache.hs +++ b/test/YesodCoreTest/Cache.hs @@ -6,12 +6,15 @@ import Test.Hspec +import Network.Wai import Network.Wai.Test import Yesod.Core import Data.IORef.Lifted import Data.Typeable (Typeable) import qualified Data.ByteString.Lazy.Char8 as L8 +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) data C = C @@ -21,9 +24,13 @@ newtype V2 = V2 Int deriving Typeable -mkYesod "C" [parseRoutes|/ RootR GET|] +mkYesod "C" [parseRoutes| +/ RootR GET +/key KeyR GET +|] -instance Yesod C +instance Yesod C where + errorHandler e = liftIO (print e) >> defaultErrorHandler e getRootR :: Handler RepPlain getRootR = do @@ -36,16 +43,32 @@ return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b] +getKeyR :: Handler RepPlain +getKeyR = do + ref <- newIORef 0 + V1 v1a <- cachedBy "1" $ atomicModifyIORef ref $ \i -> (i + 1, V1 $ i + 1) + V1 v1b <- cachedBy "1" $ atomicModifyIORef ref $ \i -> (i + 1, V1 $ i + 1) + + V2 v2a <- cachedBy "1" $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1) + V2 v2b <- cachedBy "1" $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1) + + V2 v3a <- cachedBy "2" $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1) + V2 v3b <- cachedBy "2" $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1) + + return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b, v3a, v3b] + cacheTest :: Spec cacheTest = describe "Test.Cache" $ do - it "works" works + it "cached" $ runner $ do + res <- request defaultRequest + assertStatus 200 res + assertBody (L8.pack $ show [1, 1, 2, 2 :: Int]) res + it "cachedBy" $ runner $ do + res <- request defaultRequest { pathInfo = ["key"] } + assertStatus 200 res + assertBody (L8.pack $ show [1, 1, 2, 2, 3, 3 :: Int]) res + runner :: Session () -> IO () runner f = toWaiApp C >>= runSession f - -works :: IO () -works = runner $ do - res <- request defaultRequest - assertStatus 200 res - assertBody (L8.pack $ show [1, 1, 2, 2 :: Int]) res diff --git a/test/YesodCoreTest/CleanPath.hs b/test/YesodCoreTest/CleanPath.hs --- a/test/YesodCoreTest/CleanPath.hs +++ b/test/YesodCoreTest/CleanPath.hs @@ -1,6 +1,6 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, ViewPatterns #-} {-# LANGUAGE CPP #-} module YesodCoreTest.CleanPath (cleanPathTest, Widget) where @@ -33,11 +33,7 @@ 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) diff --git a/test/YesodCoreTest/ErrorHandling.hs b/test/YesodCoreTest/ErrorHandling.hs --- a/test/YesodCoreTest/ErrorHandling.hs +++ b/test/YesodCoreTest/ErrorHandling.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} module YesodCoreTest.ErrorHandling ( errorHandlingTest , Widget diff --git a/test/YesodCoreTest/Json.hs b/test/YesodCoreTest/Json.hs --- a/test/YesodCoreTest/Json.hs +++ b/test/YesodCoreTest/Json.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ViewPatterns #-} module YesodCoreTest.Json (specs, Widget) where import Yesod.Core diff --git a/test/YesodCoreTest/Links.hs b/test/YesodCoreTest/Links.hs --- a/test/YesodCoreTest/Links.hs +++ b/test/YesodCoreTest/Links.hs @@ -1,6 +1,6 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, ViewPatterns #-} module YesodCoreTest.Links (linksTest, Widget) where import Test.Hspec diff --git a/test/YesodCoreTest/Media.hs b/test/YesodCoreTest/Media.hs --- a/test/YesodCoreTest/Media.hs +++ b/test/YesodCoreTest/Media.hs @@ -1,6 +1,6 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module YesodCoreTest.Media (mediaTest, Widget) where diff --git a/test/YesodCoreTest/NoOverloadedStrings.hs b/test/YesodCoreTest/NoOverloadedStrings.hs --- a/test/YesodCoreTest/NoOverloadedStrings.hs +++ b/test/YesodCoreTest/NoOverloadedStrings.hs @@ -1,5 +1,6 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} -- the module name is a lie!!! module YesodCoreTest.NoOverloadedStrings (noOverloadedTest, Widget) where import Test.Hspec diff --git a/test/YesodCoreTest/NoOverloadedStringsSub.hs b/test/YesodCoreTest/NoOverloadedStringsSub.hs --- a/test/YesodCoreTest/NoOverloadedStringsSub.hs +++ b/test/YesodCoreTest/NoOverloadedStringsSub.hs @@ -1,6 +1,10 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} -- hah, the test should be renamed... +-- Not actually a problem, we're now requiring overloaded strings, we just need +-- to make the docs more explicit about it. module YesodCoreTest.NoOverloadedStringsSub where import Yesod.Core diff --git a/test/YesodCoreTest/Reps.hs b/test/YesodCoreTest/Reps.hs --- a/test/YesodCoreTest/Reps.hs +++ b/test/YesodCoreTest/Reps.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ViewPatterns #-} module YesodCoreTest.Reps (specs, Widget) where import Yesod.Core diff --git a/test/YesodCoreTest/WaiSubsite.hs b/test/YesodCoreTest/WaiSubsite.hs --- a/test/YesodCoreTest/WaiSubsite.hs +++ b/test/YesodCoreTest/WaiSubsite.hs @@ -6,11 +6,7 @@ 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 diff --git a/test/YesodCoreTest/Widget.hs b/test/YesodCoreTest/Widget.hs --- a/test/YesodCoreTest/Widget.hs +++ b/test/YesodCoreTest/Widget.hs @@ -1,6 +1,6 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, ViewPatterns #-} module YesodCoreTest.Widget (widgetTest) where import Test.Hspec diff --git a/yesod-core.cabal b/yesod-core.cabal --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.2.20.1 +version: 1.4.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -25,18 +25,13 @@ library build-depends: base >= 4.3 && < 5 , time >= 1.1.4 - , yesod-routes >= 1.2 && < 1.3 - , wai >= 1.4 - , wai-extra >= 1.3 + , wai >= 3.0 + , wai-extra >= 3.0 , bytestring >= 0.9.1.4 , text >= 0.7 , template-haskell , path-pieces >= 0.1.2 && < 0.2 - , hamlet >= 1.1 - , shakespeare >= 1.0 && < 2.1 - , shakespeare-js >= 1.0.2 - , shakespeare-css >= 1.0 - , shakespeare-i18n >= 1.0 + , shakespeare >= 2.0 , blaze-builder >= 0.2.1.4 && < 0.4 , transformers >= 0.2.2 , mtl @@ -45,6 +40,7 @@ , cereal >= 0.3 , old-locale >= 1.0.0.2 && < 1.1 , containers >= 0.2 + , unordered-containers >= 0.2 , monad-control >= 0.3 && < 0.4 , transformers-base >= 0.4 , cookie >= 0.4.1 && < 0.5 @@ -54,21 +50,20 @@ , directory >= 1 , vector >= 0.9 && < 0.11 , aeson >= 0.5 - , fast-logger >= 0.2 + , fast-logger >= 2.2 , wai-logger >= 0.2 , monad-logger >= 0.3.1 && < 0.4 - , conduit >= 1.0.11 + , conduit >= 1.2 , resourcet >= 0.4.9 && < 1.2 , lifted-base >= 0.1.2 - , attoparsec-conduit , blaze-html >= 0.5 , blaze-markup >= 0.5.1 , data-default , safe - , warp >= 1.3.8 + , warp >= 3.0.2 , unix-compat , conduit-extra - , exceptions + , exceptions >= 0.6 , deepseq exposed-modules: Yesod.Core @@ -90,7 +85,19 @@ Yesod.Core.Class.Yesod Yesod.Core.Class.Dispatch Yesod.Core.Class.Breadcrumbs + Yesod.Core.TypeCache Paths_yesod_core + + Yesod.Routes.TH + Yesod.Routes.Class + Yesod.Routes.Parse + Yesod.Routes.Overlap + Yesod.Routes.TH.Dispatch + Yesod.Routes.TH.RenderRoute + Yesod.Routes.TH.ParseRoute + Yesod.Routes.TH.RouteAttrs + Yesod.Routes.TH.Types + ghc-options: -Wall -- Following line added due to: https://github.com/yesodweb/yesod/issues/545 -- This looks like a GHC bug @@ -99,6 +106,24 @@ -- Workaround for: http://ghc.haskell.org/trac/ghc/ticket/8443 extensions: TemplateHaskell +test-suite test-routes + type: exitcode-stdio-1.0 + main-is: RouteSpec.hs + hs-source-dirs: test, . + + -- Workaround for: http://ghc.haskell.org/trac/ghc/ticket/8443 + extensions: TemplateHaskell + + build-depends: base + , hspec + , containers + , bytestring + , template-haskell + , text + , random + , path-pieces + , HUnit + test-suite tests type: exitcode-stdio-1.0 main-is: test.hs @@ -107,13 +132,9 @@ cpp-options: -DTEST build-depends: base ,hspec >= 1.3 - ,wai-test >= 1.3.0.5 ,wai >= 3.0 ,yesod-core ,bytestring - ,hamlet - ,shakespeare-css - ,shakespeare-js ,text ,http-types , random @@ -142,7 +163,6 @@ , criterion , bytestring , text - , hamlet , transformers , yesod-core , blaze-html