From a9e713921ea95b70c55437bb6111ddc423d43903 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 24 Dec 2010 14:57:29 +0200 Subject: [PATCH] Removed extraneous modules, Yesod.Yesod -> Yesod.Core --- Yesod.hs | 48 ------- Yesod/{Yesod.hs => Core.hs} | 2 +- Yesod/Dispatch.hs | 4 +- Yesod/Helpers/AtomFeed.hs | 96 -------------- Yesod/Helpers/Sitemap.hs | 79 ----------- Yesod/Helpers/Static.hs | 252 ------------------------------------ yesod-core.cabal | 8 +- 7 files changed, 5 insertions(+), 484 deletions(-) delete mode 100644 Yesod.hs rename Yesod/{Yesod.hs => Core.hs} (99%) delete mode 100644 Yesod/Helpers/AtomFeed.hs delete mode 100644 Yesod/Helpers/Sitemap.hs delete mode 100644 Yesod/Helpers/Static.hs diff --git a/Yesod.hs b/Yesod.hs deleted file mode 100644 index 31dd3b88..00000000 --- a/Yesod.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE CPP #-} --- | This module simply re-exports from other modules for your convenience. -module Yesod - ( module Yesod.Request - , module Yesod.Content - , module Yesod.Yesod - , module Yesod.Handler - , module Yesod.Dispatch - , module Yesod.Hamlet - , module Yesod.Widget - , Application - , lift - , liftIO - , MonadPeelIO - , mempty - , showIntegral - , readIntegral - ) where - -#if TEST -import Yesod.Content hiding (testSuite) -import Yesod.Dispatch hiding (testSuite) -import Yesod.Yesod hiding (testSuite) -import Yesod.Handler hiding (runHandler, testSuite) -#else -import Yesod.Content -import Yesod.Dispatch -import Yesod.Yesod -import Yesod.Handler hiding (runHandler) -#endif - -import Yesod.Request -import Yesod.Widget -import Network.Wai (Application) -import Yesod.Hamlet -import Control.Monad.Trans.Class (lift) -import Control.Monad.IO.Class (liftIO) -import Data.Monoid (mempty) -import Control.Monad.IO.Peel (MonadPeelIO) - -showIntegral :: Integral a => a -> String -showIntegral x = show (fromIntegral x :: Integer) - -readIntegral :: Num a => String -> Maybe a -readIntegral s = - case reads s of - (i, _):_ -> Just $ fromInteger i - [] -> Nothing diff --git a/Yesod/Yesod.hs b/Yesod/Core.hs similarity index 99% rename from Yesod/Yesod.hs rename to Yesod/Core.hs index bb6bd498..77527f6f 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Core.hs @@ -6,7 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} -- | The basic typeclass for a Yesod application. -module Yesod.Yesod +module Yesod.Core ( -- * Type classes Yesod (..) , YesodSite (..) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index d45654ac..7086e673 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -27,10 +27,10 @@ module Yesod.Dispatch ) where #if TEST -import Yesod.Yesod hiding (testSuite) +import Yesod.Core hiding (testSuite) import Yesod.Handler hiding (testSuite) #else -import Yesod.Yesod +import Yesod.Core import Yesod.Handler #endif diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs deleted file mode 100644 index 8a5ea4a8..00000000 --- a/Yesod/Helpers/AtomFeed.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE CPP #-} ---------------------------------------------------------- --- --- Module : Yesod.Helpers.AtomFeed --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- Generating atom news feeds. --- ---------------------------------------------------------- - --- | Generation of Atom newsfeeds. See --- . -module Yesod.Helpers.AtomFeed - ( AtomFeed (..) - , AtomFeedEntry (..) - , atomFeed - , atomLink - , RepAtom (..) - ) where - -import Yesod -import Data.Time.Clock (UTCTime) - -newtype RepAtom = RepAtom Content -instance HasReps RepAtom where - chooseRep (RepAtom c) _ = return (typeAtom, c) - -atomFeed :: AtomFeed (Route master) -> GHandler sub master RepAtom -atomFeed = fmap RepAtom . hamletToContent . template - -data AtomFeed url = AtomFeed - { atomTitle :: String - , atomLinkSelf :: url - , atomLinkHome :: url - , atomUpdated :: UTCTime - , atomEntries :: [AtomFeedEntry url] - } - -data AtomFeedEntry url = AtomFeedEntry - { atomEntryLink :: url - , atomEntryUpdated :: UTCTime - , atomEntryTitle :: String - , atomEntryContent :: Html - } - -template :: AtomFeed url -> Hamlet url -template arg = -#if GHC7 - [xhamlet| -#else - [$xhamlet| -#endif - -%feed!xmlns="http://www.w3.org/2005/Atom" - %title $atomTitle.arg$ - %link!rel=self!href=@atomLinkSelf.arg@ - %link!href=@atomLinkHome.arg@ - %updated $formatW3.atomUpdated.arg$ - %id @atomLinkHome.arg@ - $forall atomEntries.arg entry - ^entryTemplate.entry^ -|] - -entryTemplate :: AtomFeedEntry url -> Hamlet url -entryTemplate arg = -#if GHC7 - [xhamlet| -#else - [$xhamlet| -#endif -%entry - %id @atomEntryLink.arg@ - %link!href=@atomEntryLink.arg@ - %updated $formatW3.atomEntryUpdated.arg$ - %title $atomEntryTitle.arg$ - %content!type=html $cdata.atomEntryContent.arg$ -|] - --- | Generates a link tag in the head of a widget. -atomLink :: Route m - -> String -- ^ title - -> GWidget s m () -atomLink u title = addHamletHead -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%link!href=@u@!type="application/atom+xml"!rel="alternate"!title=$title$ -|] diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs deleted file mode 100644 index 34807eb5..00000000 --- a/Yesod/Helpers/Sitemap.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE CPP #-} ---------------------------------------------------------- --- --- Module : Yesod.Helpers.Sitemap --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- Generating Google sitemap files. --- ---------------------------------------------------------- - --- | Generates XML sitemap files. --- --- See . -module Yesod.Helpers.Sitemap - ( sitemap - , robots - , SitemapUrl (..) - , SitemapChangeFreq (..) - ) where - -import Yesod -import Data.Time (UTCTime) - -data SitemapChangeFreq = Always - | Hourly - | Daily - | Weekly - | Monthly - | Yearly - | Never - -showFreq :: SitemapChangeFreq -> String -showFreq Always = "always" -showFreq Hourly = "hourly" -showFreq Daily = "daily" -showFreq Weekly = "weekly" -showFreq Monthly = "monthly" -showFreq Yearly = "yearly" -showFreq Never = "never" - -data SitemapUrl url = SitemapUrl - { sitemapLoc :: url - , sitemapLastMod :: UTCTime - , sitemapChangeFreq :: SitemapChangeFreq - , priority :: Double - } - -template :: [SitemapUrl url] -> Hamlet url -template urls = -#if GHC7 - [xhamlet| -#else - [$xhamlet| -#endif -%urlset!xmlns="http://www.sitemaps.org/schemas/sitemap/0.9" - $forall urls url - %url - %loc @sitemapLoc.url@ - %lastmod $formatW3.sitemapLastMod.url$ - %changefreq $showFreq.sitemapChangeFreq.url$ - %priority $show.priority.url$ -|] - -sitemap :: [SitemapUrl (Route master)] -> GHandler sub master RepXml -sitemap = fmap RepXml . hamletToContent . template - --- | A basic robots file which just lists the "Sitemap: " line. -robots :: Route sub -- ^ sitemap url - -> GHandler sub master RepPlain -robots smurl = do - tm <- getRouteToMaster - render <- getUrlRender - return $ RepPlain $ toContent $ "Sitemap: " ++ render (tm smurl) diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs deleted file mode 100644 index 7a9048f5..00000000 --- a/Yesod/Helpers/Static.hs +++ /dev/null @@ -1,252 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} ---------------------------------------------------------- --- --- Module : Yesod.Helpers.Static --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Unstable --- Portability : portable --- - --- | Serve static files from a Yesod app. --- --- This is most useful for standalone testing. When running on a production --- server (like Apache), just let the server do the static serving. --- --- In fact, in an ideal setup you'll serve your static files from a separate --- domain name to save time on transmitting cookies. In that case, you may wish --- to use 'urlRenderOverride' to redirect requests to this subsite to a --- separate domain name. -module Yesod.Helpers.Static - ( -- * Subsite - Static (..) - , StaticRoute (..) - -- * Lookup files in filesystem - , fileLookupDir - , staticFiles - -- * Embed files - , mkEmbedFiles - , getStaticHandler - -- * Hashing - , base64md5 -#if TEST - , testSuite -#endif - ) where - -import System.Directory -import Control.Monad -import Data.Maybe (fromMaybe) - -import Yesod hiding (lift) -import Data.List (intercalate) -import Language.Haskell.TH -import Language.Haskell.TH.Syntax -import Web.Routes - -import qualified Data.ByteString.Lazy as L -import Data.Digest.Pure.MD5 -import qualified Data.ByteString.Base64 -import qualified Data.ByteString.Char8 as S8 -import qualified Data.Serialize - -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) -#endif - --- | A function for looking up file contents. For serving from the file system, --- see 'fileLookupDir'. -data Static = Static - { staticLookup :: FilePath -> IO (Maybe (Either FilePath Content)) - -- | Mapping from file extension to content type. See 'typeByExt'. - , staticTypes :: [(String, ContentType)] - } - --- | Manually construct a static route. --- The first argument is a sub-path to the file being served whereas the second argument is the key value pairs in the query string. --- For example, --- > StaticRoute $ StaticR ["thumb001.jpg"] [("foo", "5"), ("bar", "choc")] --- would generate a url such as 'http://site.com/static/thumb001.jpg?foo=5&bar=choc' --- The StaticRoute constructor can be used when url's cannot be statically generated at compile-time. --- E.g. When generating image galleries. -data StaticRoute = StaticRoute [String] [(String, String)] - deriving (Eq, Show, Read) - -type instance Route Static = StaticRoute - -instance YesodSubSite Static master where - getSubSite = Site - { handleSite = \_ (StaticRoute ps _) m -> - case m of - "GET" -> Just $ fmap chooseRep $ getStaticRoute ps - _ -> Nothing - , formatPathSegments = \(StaticRoute x y) -> (x, y) - , parsePathSegments = \x -> Right $ StaticRoute x [] - } - --- | Lookup files in a specific directory. --- --- If you are just using this in combination with the static subsite (you --- probably are), the handler itself checks that no unsafe paths are being --- requested. In particular, no path segments may begin with a single period, --- so hidden files and parent directories are safe. --- --- For the second argument to this function, you can just use 'typeByExt'. -fileLookupDir :: FilePath -> [(String, ContentType)] -> Static -fileLookupDir dir = Static $ \fp -> do - let fp' = dir ++ '/' : fp - exists <- doesFileExist fp' - if exists - then return $ Just $ Left fp' - else return Nothing - --- | Lookup files in a specific directory, and embed them into the haskell source. --- --- A variation of fileLookupDir which allows subsites distributed via cabal to include --- static content. You can still use staticFiles to generate route identifiers. See getStaticHandler --- for dispatching static content for a subsite. -mkEmbedFiles :: FilePath -> Q Exp -mkEmbedFiles d = do - fs <- qRunIO $ getFileList d - clauses <- mapM (mkClause . intercalate "/") fs - defC <- defaultClause - return $ static $ clauses ++ [defC] - where static clauses = LetE [fun clauses] $ ConE 'Static `AppE` VarE f - f = mkName "f" - fun clauses = FunD f clauses - defaultClause = do - b <- [| return Nothing |] - return $ Clause [WildP] (NormalB b) [] - - mkClause path = do - content <- qRunIO $ readFile $ d ++ '/':path - let pat = LitP $ StringL path - foldAppE = foldl1 AppE - content' = return $ LitE $ StringL $ content - body <- normalB [| return $ Just $ Right $ toContent ($content' :: [Char]) |] - return $ Clause [pat] body [] - --- | Dispatch static route for a subsite --- --- Subsites with static routes can't (yet) define Static routes the same way "master" sites can. --- Instead of a subsite route: --- /static StaticR Static getStatic --- Use a normal route: --- /static/*Strings StaticR GET --- --- Then, define getStaticR something like: --- getStaticR = getStaticHandler ($(mkEmbedFiles "static") typeByExt) StaticR --- */ end CPP comment -getStaticHandler :: Static -> (StaticRoute -> Route sub) -> [String] -> GHandler sub y ChooseRep -getStaticHandler static toSubR pieces = do - toMasterR <- getRouteToMaster - toMasterHandler (toMasterR . toSubR) toSub route handler - where route = StaticRoute pieces [] - toSub _ = static - staticSite = getSubSite :: Site (Route Static) (String -> Maybe (GHandler Static y ChooseRep)) - handler = fromMaybe notFound $ handleSite staticSite undefined route "GET" - -getStaticRoute :: [String] - -> GHandler Static master (ContentType, Content) -getStaticRoute fp' = do - Static fl ctypes <- getYesodSub - when (any isUnsafe fp') notFound - let fp = intercalate "/" fp' - content <- liftIO $ fl fp - case content of - Nothing -> notFound - Just (Left fp'') -> do - let ctype = fromMaybe typeOctet $ lookup (ext fp'') ctypes - sendFile ctype fp'' - Just (Right bs) -> do - let ctype = fromMaybe typeOctet $ lookup (ext fp) ctypes - return (ctype, bs) - where - isUnsafe [] = True - isUnsafe ('.':_) = True - isUnsafe _ = False - -notHidden :: FilePath -> Bool -notHidden ('.':_) = False -notHidden "tmp" = False -notHidden _ = True - -getFileList :: FilePath -> IO [[String]] -getFileList = flip go id - where - go :: String -> ([String] -> [String]) -> IO [[String]] - go fp front = do - allContents <- filter notHidden `fmap` getDirectoryContents fp - let fullPath :: String -> String - fullPath f = fp ++ '/' : f - files <- filterM (doesFileExist . fullPath) allContents - let files' = map (front . return) files - dirs <- filterM (doesDirectoryExist . fullPath) allContents - dirs' <- mapM (\f -> go (fullPath f) (front . (:) f)) dirs - return $ concat $ files' : dirs' - --- | This piece of Template Haskell will find all of the files in the given directory and create Haskell identifiers for them. For example, if you have the files \"static\/style.css\" and \"static\/js\/script.js\", it will essentailly create: --- --- > style_css = StaticRoute ["style.css"] [] --- > js_script_js = StaticRoute ["js/script.js"] [] -staticFiles :: FilePath -> Q [Dec] -staticFiles fp = do - fs <- qRunIO $ getFileList fp - concat `fmap` mapM go fs - where - replace' c - | 'A' <= c && c <= 'Z' = c - | 'a' <= c && c <= 'z' = c - | '0' <= c && c <= '9' = c - | otherwise = '_' - go f = do - let name = mkName $ intercalate "_" $ map (map replace') f - f' <- lift f - let sr = ConE $ mkName "StaticRoute" - hash <- qRunIO $ fmap base64md5 $ L.readFile $ fp ++ '/' : intercalate "/" f - let qs = ListE [TupE [LitE $ StringL hash, ListE []]] - return - [ SigD name $ ConT ''Route `AppT` ConT ''Static - , FunD name - [ Clause [] (NormalB $ sr `AppE` f' `AppE` qs) [] - ] - ] - -#if TEST - -testSuite :: Test -testSuite = testGroup "Yesod.Helpers.Static" - [ testCase "get file list" caseGetFileList - ] - -caseGetFileList :: Assertion -caseGetFileList = do - x <- getFileList "test" - x @?= [["foo"], ["bar", "baz"]] - -#endif - --- | md5-hashes the given lazy bytestring and returns the hash as --- base64url-encoded string. --- --- This function returns the first 8 characters of the hash. -base64md5 :: L.ByteString -> String -base64md5 = map go - . take 8 - . S8.unpack - . Data.ByteString.Base64.encode - . Data.Serialize.encode - . md5 - where - go '+' = '-' - go '/' = '_' - go c = c diff --git a/yesod-core.cabal b/yesod-core.cabal index 39f97acf..14c025cb 100644 --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -57,17 +57,13 @@ library , cookie >= 0.0 && < 0.1 , json-enumerator >= 0.0 && < 0.1 , json-types >= 0.1 && < 0.2 - exposed-modules: Yesod - Yesod.Content + exposed-modules: Yesod.Content + Yesod.Core Yesod.Dispatch Yesod.Hamlet Yesod.Handler Yesod.Request Yesod.Widget - Yesod.Yesod - Yesod.Helpers.AtomFeed - Yesod.Helpers.Sitemap - Yesod.Helpers.Static other-modules: Yesod.Internal Paths_yesod_core ghc-options: -Wall