yesod-core 1.2.20.1 → 1.4.0
raw patch · 34 files changed
+1495/−413 lines, 34 filesdep +unordered-containersdep −attoparsec-conduitdep −hamletdep −shakespeare-cssdep ~basedep ~bytestringdep ~conduit
Dependencies added: unordered-containers
Dependencies removed: attoparsec-conduit, hamlet, shakespeare-css, shakespeare-i18n, shakespeare-js, wai-test, yesod-routes
Dependency ranges changed: base, bytestring, conduit, conduit-extra, containers, exceptions, fast-logger, hspec, path-pieces, random, shakespeare, text, vector, wai, wai-extra, warp
Files
- Yesod/Core/Class/Handler.hs +2/−8
- Yesod/Core/Class/Yesod.hs +2/−47
- Yesod/Core/Content.hs +8/−4
- Yesod/Core/Dispatch.hs +17/−31
- Yesod/Core/Handler.hs +38/−87
- Yesod/Core/Internal/Request.hs +0/−20
- Yesod/Core/Internal/Response.hs +4/−83
- Yesod/Core/Internal/Run.hs +6/−35
- Yesod/Core/Json.hs +0/−5
- Yesod/Core/TypeCache.hs +83/−0
- Yesod/Core/Types.hs +6/−46
- Yesod/Routes/Class.hs +21/−0
- Yesod/Routes/Overlap.hs +88/−0
- Yesod/Routes/Parse.hs +254/−0
- Yesod/Routes/TH.hs +16/−0
- Yesod/Routes/TH/Dispatch.hs +199/−0
- Yesod/Routes/TH/ParseRoute.hs +43/−0
- Yesod/Routes/TH/RenderRoute.hs +150/−0
- Yesod/Routes/TH/RouteAttrs.hs +38/−0
- Yesod/Routes/TH/Types.hs +100/−0
- test/RouteSpec.hs +336/−0
- test/YesodCoreTest.hs +0/−4
- test/YesodCoreTest/Cache.hs +32/−9
- test/YesodCoreTest/CleanPath.hs +1/−5
- test/YesodCoreTest/ErrorHandling.hs +1/−0
- test/YesodCoreTest/Json.hs +1/−1
- test/YesodCoreTest/Links.hs +1/−1
- test/YesodCoreTest/Media.hs +1/−1
- test/YesodCoreTest/NoOverloadedStrings.hs +2/−1
- test/YesodCoreTest/NoOverloadedStringsSub.hs +4/−0
- test/YesodCoreTest/Reps.hs +1/−1
- test/YesodCoreTest/WaiSubsite.hs +0/−4
- test/YesodCoreTest/Widget.hs +1/−1
- yesod-core.cabal +39/−19
Yesod/Core/Class/Handler.hs view
@@ -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
Yesod/Core/Class/Yesod.hs view
@@ -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'.
Yesod/Core/Content.hs view
@@ -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
Yesod/Core/Dispatch.hs view
@@ -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
Yesod/Core/Handler.hs view
@@ -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: <http://www.yesodweb.com/blog/2013/03/yesod-1-2-cleaner-internals>+-- -- 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@.
Yesod/Core/Internal/Request.hs view
@@ -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
Yesod/Core/Internal/Response.hs view
@@ -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
Yesod/Core/Internal/Run.hs view
@@ -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'
Yesod/Core/Json.hs view
@@ -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
+ Yesod/Core/TypeCache.hs view
@@ -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: <http://www.yesodweb.com/blog/2013/03/yesod-1-2-cleaner-internals>+--+-- 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)
Yesod/Core/Types.hs view
@@ -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 <head> -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
+ Yesod/Routes/Class.hs view
@@ -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
+ Yesod/Routes/Overlap.hs view
@@ -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
+ Yesod/Routes/Parse.hs view
@@ -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)
+ Yesod/Routes/TH.hs view
@@ -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
+ Yesod/Routes/TH/Dispatch.hs view
@@ -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
+ Yesod/Routes/TH/ParseRoute.hs view
@@ -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
+ Yesod/Routes/TH/RenderRoute.hs view
@@ -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]
+ Yesod/Routes/TH/RouteAttrs.hs view
@@ -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)
+ Yesod/Routes/TH/Types.hs view
@@ -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
+ test/RouteSpec.hs view
@@ -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
test/YesodCoreTest.hs view
@@ -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
test/YesodCoreTest/Cache.hs view
@@ -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
test/YesodCoreTest/CleanPath.hs view
@@ -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)
test/YesodCoreTest/ErrorHandling.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-} module YesodCoreTest.ErrorHandling ( errorHandlingTest , Widget
test/YesodCoreTest/Json.hs view
@@ -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
test/YesodCoreTest/Links.hs view
@@ -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
test/YesodCoreTest/Media.hs view
@@ -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
test/YesodCoreTest/NoOverloadedStrings.hs view
@@ -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
test/YesodCoreTest/NoOverloadedStringsSub.hs view
@@ -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
test/YesodCoreTest/Reps.hs view
@@ -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
test/YesodCoreTest/WaiSubsite.hs view
@@ -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
test/YesodCoreTest/Widget.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances, ViewPatterns #-} module YesodCoreTest.Widget (widgetTest) where import Test.Hspec
yesod-core.cabal view
@@ -1,5 +1,5 @@ name: yesod-core-version: 1.2.20.1+version: 1.4.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -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