yesod-articles (empty) → 0.1.0.0
raw patch · 5 files changed
+417/−0 lines, 5 filesdep +basedep +blaze-htmldep +datessetup-changed
Dependencies added: base, blaze-html, dates, directory, filepath, hspec, regex-compat, shakespeare, template-haskell, text, th-lift-instances, yesod, yesod-articles, yesod-core, yesod-test
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- src/Yesod/Articles.hs +254/−0
- test/main.hs +33/−0
- yesod-articles.cabal +98/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2017, Matthew Eads++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Matthew Eads nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Yesod/Articles.hs view
@@ -0,0 +1,254 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+module Yesod.Articles where+import Prelude+import Language.Haskell.TH+import System.Directory+import Text.Hamlet as NP+import qualified Data.Text as T +import Data.Text (Text, pack, splitOn, intercalate, isSuffixOf, unpack)+import qualified Data.Text.IO as TI+import Data.Dates (DateTime, parseDate, getCurrentDateTime)+import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Language.Haskell.TH.Syntax+import Text.Regex+import Data.List (sortBy)+import Yesod.Core.Widget+import Instances.TH.Lift+import Text.Blaze.Html (toHtml)+import Yesod.Core.Handler (getMessageRender, getUrlRenderParams, notFound)+import System.FilePath.Posix++-- | Snatched from Yesod.Core.Widget, used in other functions+rules :: Q NP.HamletRules+rules = do+ ah <- [|asWidgetT . toWidget|]+ let helper qg f = do+ x <- newName "urender"+ e <- f $ VarE x+ let e' = LamE [VarP x] e+ g <- qg+ bind <- [|(>>=)|]+ return $ InfixE (Just g) bind (Just e')+ let ur f = do+ let env = NP.Env+ (Just $ helper [|getUrlRenderParams|])+ (Just $ helper [|fmap (toHtml .) getMessageRender|])+ f env+ return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b++-- | Takes a file path/name (ex. templates/articles/foo.hamlet)+-- Looks at the first line, which should contain the date in the form <!--YYYY-MM-DD-->+-- If date is malformed or nonexistent, it returns todays date.+getDate :: Text -> IO DateTime+getDate file = + do+ contents <- TI.readFile $ unpack file+ today <- getCurrentDateTime+ return $ + let header = getHeader contents+ rgx = mkRegexWithOpts "<!--([[:digit:]]{4}.[[:digit:]]{2}.[[:digit:]]{2})-->" False True + date_str = case matchRegex rgx $ unpack header of+ Just matches -> head matches+ Nothing -> "1970-01-01"+ date_str' = map (\x -> if x == '-' then '/' else x) date_str -- parseDate wants dates seperated by / not -+ date = case Data.Dates.parseDate today date_str' of+ Right d -> d+ _ -> today+ in date++-- | Recursively fetches dates for a given list of file paths+getDates :: [Text] -> IO [DateTime]+getDates [] = return []+getDates (x:xs) = + do + date <- getDate x+ dates <- getDates xs+ return (date:dates)+ +-- | Fetch the paths for all the .hamlet files in the templates/articles/ dir.+-- Returns the articles as a list of strings, sorted by date, newest->oldest,+-- based on the dates from getDate(s). +-- File names returned are of the form "templates/articles/foo.hamlet"+getArticleNames :: Text -> IO [Text]+getArticleNames path = + do {+ files <- getDirectoryContents $ unpack path;+ let hamlet_files = filter (isSuffixOf ".hamlet") (map pack files)+ file_names_2 = map (\fname -> pack $ joinPath [unpack path, unpack fname]) hamlet_files+ in do {+ dates <- getDates file_names_2;+ return (map fst $ sortBy (\(x,y) -> \(x', y') -> compare y' y) $ zip file_names_2 dates);+ }+ }++-- | Takes a file path (templates/articles/foo.hamlet), and returns+-- a string of just the file name without the extension (foo).+stripName :: Text -> Text+stripName file_name = pack $ takeBaseName $ unpack file_name++-- | Takes a file path (templates/articles/foo.hamlet), and returns+-- a route name for it (fooR). Undefined behaviour if file names not fetched from+-- getArticleNames (or if not prefixed by templates/articles/ and suffixed by .hamlet)+makeRouteName :: Text -> Text+makeRouteName file_name = T.concat [stripName file_name, "R"]++-- | Generates the Read More... link for an article. +readMore :: Text -> Text+readMore fp = T.concat ["<p><a href=@{ArticleR \"", stripName fp, "\"}>Read More...</a>\n"]+ --read_more = concat ["<p><a href=@{", makeRouteName fp, "}>Read More...</a>\n"]++contentsLink :: Text -> Text+contentsLink fp = T.concat ["<div syle=\"display:none\" #", stripName fp, ">\n"]++-- | See https://hackage.haskell.org/package/shakespeare-2.0.12.1/docs/src/Text-Hamlet.html#hamletFileWithSettings+-- This replaces hamletFileWithSettings, instead of just passing the full contents to hamletFromString,+-- We truncate the contents (currently just up to not including the third <p> tag+-- and append the 'Read More...' link.+getPreview :: Q HamletRules -> HamletSettings -> FilePath -> Q Exp+getPreview qhr set fp = do+-- #ifdef GHC_7_4+-- qAddDependentFile fp+-- #endif+ contents <- fmap T.unpack $ runIO $ TI.readFile fp+ -- hear we can truncate the contents+ let split_contents = splitOn "<p>" $ pack contents+ let take_n = if Prelude.length split_contents > 3 then 3 else Prelude.length split_contents+ let preview = intercalate "<p>" $ take take_n split_contents+ let read_more = readMore $ pack fp+ let contents_link = contentsLink $ pack fp+ hamletFromString qhr set $ unpack $ intercalate "\n" [contents_link, preview, read_more]+++makePreviews :: Q Exp+makePreviews = makePreviewsWithOptions "templates/articles"++-- | This can be used to make the previews for all the articles+-- It fetches the articles to display, and for each one calls our modified+-- hamletFileWithSettings (getPreview) +makePreviewsWithOptions :: Text -> Q Exp+makePreviewsWithOptions path = + do + articles <- runIO $ getArticleNames path+ xs <- mapM (\x -> getPreview rules NP.defaultHamletSettings $ unpack x) articles+ return $ DoE (map NoBindS xs)+ + +-- | Given a stripped article names (eg 'civ6', 'foo'), makeGet+-- will create the functions which 'gets' that article. It names the function+-- by prefixing the article name with 'get' and suffixing with 'R' (eg 'foo' -> 'getfooR')+-- The function returned calls defaultLayout, sets the title based on the +-- given prefix and the article name, and calls widgetFile on the article.+-- The function returned effectively does:+-- defaultLayout $ do {+-- $(setTitle prefix ++ article_name)+-- $(widgetFile articles/article_name)}+makeGet :: Text -> Text -> Q Exp -> Text -> Q Dec+makeGet prefix path exp article_name = + let article_name' = unpack article_name+ prefix' = unpack prefix+ fname = mkName $ concat ["get", article_name', "R"]+ in + do {+ dl <- exp;+ widget <- whamletFile $ joinPath [unpack path, addExtension article_name' ".hamlet"];+ --dl <- [e|defaultLayout|];+ title <- runIO $ getTitle (pack $ joinPath [unpack path, addExtension article_name' ".hamlet"]);+ set_title <- [e| setTitle $ toHtml (prefix' ++ " " ++ (unpack title)) |];+ --decs <- makeGet rest;+ return (ValD (VarP fname) + (NormalB (AppE dl {-(VarE (mkName "defaultLayout"))-} (ParensE+ (DoE [NoBindS set_title,+ NoBindS widget])))) []);+ }+++makeGets :: Q [Dec]+makeGets = makeGetsWithOptions "" "templates/articles/" (return (VarE (mkName "defaultLayout"))) -- maybe change this++-- arg example+-- makeGetsWithOptions prefix "Matt Eads:"+-- path "templates/articles/" -- make sure we add a / to the end if needed+-- exp [e|\x -> do defaultLayout $ x|] -- not sure what the default should be here+-- ++-- | Gets the list of articles in templates/articles, makes all+-- the 'getter' functions for the articles (see makeGet), and creates+-- the 'getArticleR' function (see makeGetArticle).+makeGetsWithOptions :: Text -> Text -> Q Exp -> Q [Dec]+makeGetsWithOptions prefix path exp =+ do+ articles <- runIO $ getArticleNames path+ let articles' = map stripName articles+ decs <- mapM (makeGet prefix path exp) articles'+ getArticle <- makeGetArticle articles'+ return (decs ++ getArticle)++-- | Given a list of articles, returns the 'getArticleR' function.+-- The function returned will take the article_name as an arg, and+-- defer to the appropriate get<article_name>R function. This relies+-- on the makeGet function being already run on the same articles given to +-- it. This is the handler for the /article/#Text route. +makeGetArticle :: [Text] -> Q [Dec]+makeGetArticle articles = + let fname = mkName "getArticleR"+ arg = mkName "article_name"+ article_cases = map (\article -> Match (LitP (StringL $ unpack article)) + (NormalB (VarE $ mkName $ concat ["get", unpack article, "R"]))[]) articles+ in+ do {+ notfound <- [e|notFound|];+ return [FunD fname [Clause [VarP arg]+ (NormalB (CaseE (VarE arg)+ (article_cases ++ [Match WildP (NormalB notfound) []])))[]]] + + }++-- | Given the contents of an article, returns the 'article header'+-- that is the contents of the file up to the first html tag (<p>, <h3>, etc.)+getHeader :: Text -> Text+getHeader contents = + let rgx = mkRegexWithOpts "(.*)<[a-zA-Z]" False True + in case matchRegex rgx $ unpack contents of+ (Just matches) -> pack $ head matches+ Nothing -> ""++-- | Given a file path, returns the page title for the article.+-- The title should be a html comment (<!--title-->) and occur before+-- any other text, other than the date comment. The date and title can+-- be put in either order. If no title can be found, the stripped file+-- path is used.+getTitle :: Text -> IO Text+getTitle fp = + do+ contents <- TI.readFile $ unpack fp+ return $ + let header = getHeader contents+ rgx = mkRegexWithOpts "<!--[[:digit:]]{4}.[[:digit:]]{2}.[[:digit:]]{2}-->" False True + non_match = case matchRegexAll rgx $ unpack header of + Nothing -> ""+ Just (before, _, after, _) -> concat [before, after]+ rgx2 = mkRegexWithOpts "<!--(.*)-->" False True + in case matchRegex rgx2 non_match of+ (Just matches) -> pack $ head matches+ Nothing -> stripName fp+++makeContentsEntry :: (Text, Text) -> Text+makeContentsEntry (id, title) = T.concat ["<li><a href=\"#", id, "\">", title, "</a>"]++makeContents :: Q Exp+makeContents = makeContentsWithOptions "templates/articles"++-- | Makes the contents for the page of previews. +makeContentsWithOptions :: Text -> Q Exp+makeContentsWithOptions path = + do + articles <- runIO $ getArticleNames path+ titles <- runIO $ mapM getTitle articles+ let articles' = zip (map stripName articles) titles+ let entries = map makeContentsEntry articles'+ ham <- hamletFromString rules NP.defaultHamletSettings $ + unpack $ intercalate "\n " (["<div #contents>\n <ul>"] ++ entries)+ return $ DoE [NoBindS ham]+
+ test/main.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+import Test.Hspec+import Data.Text+import Yesod hiding (get)+import Yesod.Articles+import Yesod.Test+import Handlers+++spec :: Spec+spec = yesodSpec (ArticlesTestApp) $ do+ ydescribe "Basic test" $ do + yit "Get homepage with previews and contents" $ do+ get ("/" :: Text)+ statusIs 200+ -- printBody+ bodyContains "Test paragraph 1.1"+ bodyNotContains "Test paragraph 1.5"+ bodyContains "<a href=/articles/test1>Read More...</a>"+ bodyContains "<li><a href=\"#test1\">Test Article 1</a>"++ get ("/articles/test1" :: Text)+ statusIs 200+ -- printBody+ bodyContains "Test paragraph 1.5"+ bodyContains "<title>Test: Test Article 1</title>"++main :: IO ()+main = hspec spec
+ yesod-articles.cabal view
@@ -0,0 +1,98 @@+-- Initial yesod-articles.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++-- The name of the package.+name: yesod-articles++-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented.+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.1.0.0++-- A short (one-line) description of the package.+synopsis: Automatically generate article previews for a yesod site++-- A longer description of the package.+-- description: ++-- URL for the project homepage or repository.+homepage: https://github.com/matthew-eads/yesod-articles++-- The license under which the package is released.+license: BSD3++-- The file containing the license text.+license-file: LICENSE++-- The package author(s).+author: Matthew Eads++-- An email address to which users can send suggestions, bug reports, and +-- patches.+maintainer: mattaeads@gmail.com++-- A copyright notice.+-- copyright: ++category: Web, Yesod++build-type: Simple++-- Constraint on the version of Cabal needed to build this package.+cabal-version: >=1.8+++library++ hs-source-dirs: src+ -- Modules exported by the library.+ exposed-modules: Yesod.Articles+ + -- Modules included in this library but not exported.+ -- other-modules: + + -- Other library packages from which modules are imported.+ build-depends: base >= 4.8.2.0 && < 4.9+ || >= 4.9.1.0 && < 5+ , yesod >= 1.4.3 && < 1.5+ , yesod-core >= 1.4.17 && < 1.5+ , regex-compat + , template-haskell+ , dates >= 0.2.2.0+ , text >= 0.11 && < 2.0+ , shakespeare >= 2.0 && < 2.1+ , directory >= 1.1 && < 1.3+ , th-lift-instances+ , blaze-html+ , filepath++test-suite test+ type: exitcode-stdio-1.0+ main-is: main.hs+ hs-source-dirs: test+ ghc-options: -Wall+ build-depends: base >= 4.8.2.0 && < 4.9+ || >= 4.9.1.0 && < 5+ , yesod >= 1.4.3 && < 1.5+ , yesod-core >= 1.4.17 && < 1.5+ , regex-compat + , template-haskell+ , dates >= 0.2.2.0+ , text >= 0.11 && < 2.0+ , shakespeare >= 2.0 && < 2.1+ , directory >= 1.1 && < 1.3+ , th-lift-instances+ , blaze-html+ , filepath+ , hspec+ , yesod-test+ , yesod-articles++ ++source-repository head+ type: git+ location: git://github.com/matthew-eads/yesod-articles.git