stagen 0.1.0 → 0.2.0
raw patch · 12 files changed
+312/−49 lines, 12 filesdep +base-compatdep +feeddep +json-feed
Dependencies added: base-compat, feed, json-feed, network-uri, text-conversions, xml, xml-conduit, xml-types
Files
- README.md +27/−0
- library/Stagen/AtomFeed.hs +67/−0
- library/Stagen/Build.hs +30/−31
- library/Stagen/Clean.hs +1/−1
- library/Stagen/Date.hs +5/−0
- library/Stagen/File.hs +32/−7
- library/Stagen/JsonFeed.hs +53/−0
- library/Stagen/Opts.hs +5/−2
- library/Stagen/Page.hs +4/−1
- library/Stagen/RssFeed.hs +55/−0
- package.yaml +10/−1
- stagen.cabal +23/−6
README.md view
@@ -1,1 +1,28 @@ # stagen++## Installation++[Download stack](https://docs.haskellstack.org/en/stable/README/#how-to-install)++```shell+stack build+stack install+```++++## Installed?++Try++```shell+stagen+```++Should output this++```shell+Missing: COMMAND++Usage: stagen COMMAND+```
+ library/Stagen/AtomFeed.hs view
@@ -0,0 +1,67 @@+module Stagen.AtomFeed where++import qualified Data.Text.Lazy as TL+import qualified Text.Atom.Feed as Atom+import qualified Text.Atom.Feed.Export as Export++import Prelude ()+import Prelude.Compat hiding (take)+import Data.Text hiding (map)+import Data.Text.Conversions (toText)+import Data.Text.Lazy (toStrict)+import Data.XML.Types as XML+import Text.XML as C+import Data.Maybe++import Stagen.Date+import Stagen.Page++createAtomFeed :: String -> FilePath -> [Page] -> Maybe TL.Text+createAtomFeed title baseUrl+ = fmap TL.fromStrict+ . feed title baseUrl+ . catMaybes+ . map (\page -> case pageDate page of+ Nothing -> Nothing+ Just date -> Just (toAtomDate date, toStrict $ pageAbsoluteUrl page, Atom.TextString . toStrict $ pageTitle page))++toAtomDate :: Date -> Atom.Date+toAtomDate Date{dateYear,dateMonth,dateDay} = toText $ mconcat+ [ show dateYear+ , "-"+ , showTwoDigits dateMonth+ , "-"+ , showTwoDigits dateDay+ , "T00:00:00Z"+ ]++feed :: String -> FilePath -> [(Atom.Date, Atom.URI, Atom.TextContent)] -> Maybe Text+feed blogTitle baseUrl posts =+ fmap (toStrict . renderText def) $+ elementToDoc $+ Export.xmlFeed $+ fd {Atom.feedEntries = fmap toEntry posts, Atom.feedLinks = [Atom.nullLink $ toText baseUrl]}+ where+ fd :: Atom.Feed+ fd =+ Atom.nullFeed+ (toText baseUrl `mappend` "/atom.xml") -- ID+ (Atom.TextString $ toText blogTitle) -- Title+ (case posts -- Updated+ of+ (latestPostDate, _, _):_ -> latestPostDate+ _ -> "")+ toEntry :: (Atom.Date, Atom.URI, Atom.TextContent) -> Atom.Entry+ toEntry (date, url, title) =+ (Atom.nullEntry+ url -- The ID field. Must be a link to validate.+ title -- Title+ date)+ { Atom.entryAuthors = [Atom.nullPerson]+ , Atom.entryLinks = [Atom.nullLink url]+ , Atom.entryContent = Nothing+ }++elementToDoc :: XML.Element -> Maybe C.Document+elementToDoc el =+ either (const Nothing) Just $ fromXMLDocument $ XML.Document (Prologue [] Nothing []) el []
library/Stagen/Build.hs view
@@ -3,9 +3,8 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.IO as TL+import qualified Data.ByteString.Lazy as BL import qualified Data.List as L-import qualified Text.Parsec as P-import qualified Text.Parsec.String as P import Control.Arrow import Control.Monad (void) import System.FilePath.Find@@ -18,6 +17,9 @@ import Stagen.Template import Stagen.Page import Stagen.Job+import Stagen.AtomFeed (createAtomFeed)+import Stagen.RssFeed (createRssFeed)+import Stagen.JsonFeed (createJsonFeed) import Stagen.File runBuild :: Opts -> IO ()@@ -25,10 +27,14 @@ tpl <- mkTemplate opts let ignore = optsIgnore ++ catMaybes [optsHeader, optsFooter, optsArchive] files <- find (pure True) (eligable ignore) optsTargetDirectory- htmlPathAndPages <- sequence $ map (fromMarkdown optsVerbose) files- let archive = archiveJob optsVerbose tpl htmlPathAndPages optsArchive+ htmlPathAndPages <- sequence $ map (fromMarkdown optsVerbose optsBaseUrl) files+ let archive = archiveJob optsVerbose tpl optsBaseUrl htmlPathAndPages optsArchive let pageAndHtmlPaths = map (\(page, path) -> (path, page)) htmlPathAndPages- let jobs = archive : map (uncurry (writePage tpl)) pageAndHtmlPaths+ let feedPages = reverse (map snd htmlPathAndPages)+ let atomFeed = fromMaybe (return ()) $ fmap writeAtomXml $ createAtomFeed optsTitle optsBaseUrl feedPages+ let rssFeed = fromMaybe (return ()) $ fmap writeRssXml $ createRssFeed optsTitle optsBaseUrl feedPages+ let jsonFeed = writeFeedJson $ createJsonFeed optsTitle optsBaseUrl feedPages+ let jobs = archive : atomFeed : rssFeed : jsonFeed : map (uncurry (writePage tpl)) pageAndHtmlPaths void $ runJobs optsJobs jobs build :: Template -> Page -> TL.Text@@ -45,27 +51,36 @@ where try = toHtmlRaw . fromMaybe TL.empty -archiveJob :: Verbose -> Template -> [(FilePath, Page)] -> Maybe FilePath -> IO ()-archiveJob verbose tpl htmlPathAndPages mMdPath = fromMaybe (return ()) $ do+archiveJob :: Verbose -> Template -> FilePath -> [(FilePath, Page)] -> Maybe FilePath -> IO ()+archiveJob verbose tpl baseUrl htmlPathAndPages mMdPath = fromMaybe (return ()) $ do mdPath <- mMdPath return $ do- (htmlPath, page) <- fromMarkdown verbose mdPath- writePage tpl (addArchiveEntries page htmlPathAndPages) htmlPath+ (htmlPath, page) <- fromMarkdown verbose baseUrl mdPath+ writePage tpl (addArchiveEntries baseUrl mdPath page htmlPathAndPages) htmlPath -writePageFromMarkdown :: Verbose -> Template -> FilePath -> IO ()-writePageFromMarkdown verbose tpl mdPath = do- (htmlPath, page) <- fromMarkdown verbose mdPath+writePageFromMarkdown :: Verbose -> Template -> FilePath -> FilePath -> IO ()+writePageFromMarkdown verbose tpl baseUrl mdPath = do+ (htmlPath, page) <- fromMarkdown verbose baseUrl mdPath writePage tpl page htmlPath writePage :: Template -> Page -> FilePath -> IO () writePage tpl page htmlPath = TL.writeFile htmlPath (build tpl page) -addArchiveEntries :: Page -> [(FilePath, Page)] -> Page-addArchiveEntries page htmlPathAndPages =+writeAtomXml :: TL.Text -> IO ()+writeAtomXml = TL.writeFile "atom.xml"++writeRssXml :: TL.Text -> IO ()+writeRssXml = TL.writeFile "rss.xml"++writeFeedJson :: BL.ByteString -> IO ()+writeFeedJson = BL.writeFile "feed.json"++addArchiveEntries :: FilePath -> FilePath -> Page -> [(FilePath, Page)] -> Page+addArchiveEntries baseUrl archivePath page htmlPathAndPages = let pathAndTitles = map (second pageTitle) htmlPathAndPages sorter = L.sortBy (\(_,_,a) (_,_,b)-> compare b a) content = (pageContent page) <> (toLinks . sorter . getEntries) pathAndTitles- in Page{pageTitle = pageTitle page, pageContent = content}+ in Page{pageTitle = pageTitle page, pageContent = content, pageDate = Nothing, pageAbsoluteUrl = absoluteUrl baseUrl archivePath } where getEntries :: [(FilePath, TL.Text)] -> [(FilePath, TL.Text, Date)] getEntries = catMaybes . map (\(f,t) -> fmap (f,t,) (parseMay datePrefix (baseName f)))@@ -87,22 +102,6 @@ , "-" , TL.pack (showTwoDigits dateDay) ]- where- showTwoDigits n- | n < 10 = '0' : show n- | otherwise = show n--parseMay :: P.Parser a -> String -> Maybe a-parseMay p src = case P.parse p "" src of- Left _ -> Nothing- Right x -> Just x--baseName :: FilePath -> FilePath-baseName path = basename- where- revPath = reverse path- revName = takeWhile (/= '/') revPath- basename = reverse (dropWhile (/= '.') revName) mkTemplate :: Opts -> IO Template mkTemplate Opts{..} = do
library/Stagen/Clean.hs view
@@ -13,7 +13,7 @@ runClean Opts{..} = do let ignore = optsIgnore ++ catMaybes [optsHeader, optsFooter] files <- find (pure True) (eligable ignore) optsTargetDirectory- htmlPaths <- map fst <$> (sequence $ map (fromMarkdown optsVerbose) files)+ htmlPaths <- map fst <$> (sequence $ map (fromMarkdown optsVerbose optsBaseUrl) files) mapM_ (\p -> catchIOError (removeFile p) (const done)) htmlPaths where done = return ()
library/Stagen/Date.hs view
@@ -21,3 +21,8 @@ return (Date year month day) where number = fmap read (many1 digit)++showTwoDigits :: (Show a, Num a, Ord a) => a -> String+showTwoDigits n+ | n < 10 = '0' : show n+ | otherwise = show n
library/Stagen/File.hs view
@@ -2,6 +2,10 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.IO as TL+import qualified Text.Parsec as P+import qualified Text.Parsec.String as P+import Data.Text.Conversions (toText)+import Data.Monoid ((<>)) import Control.Monad (when) import System.FilePath.Find import Text.Markdown@@ -9,11 +13,12 @@ import Stagen.Opts import Stagen.Page+import Stagen.Date -fromMarkdown :: Verbose -> FilePath -> IO (FilePath, Page)-fromMarkdown verbose mdPath = do+fromMarkdown :: Verbose -> FilePath -> FilePath -> IO (FilePath, Page)+fromMarkdown verbose baseUrl mdPath = do let htmlPath = changeExtension mdPath "html"- page <- readPage mdPath+ page <- readPage baseUrl mdPath when (verbose == Verbose) (putStrLn htmlPath) return (htmlPath, page) @@ -24,13 +29,21 @@ let isFileName = and (map (/= name) ignore) return (isMarkdown && isFileName) -readPage :: FilePath -> IO Page-readPage path = do+absoluteUrl :: FilePath -> FilePath -> TL.Text+absoluteUrl baseUrl path = TL.fromStrict . toText $ changeExtension (baseUrl <> "/" <> path) "html"++readPage :: FilePath -> FilePath -> IO Page+readPage baseUrl path = do content <- TL.readFile path- let pageTitle = TL.filter (not . isMarkdownChar) (TL.takeWhile isNotNewLine content)+ let pageAbsoluteUrl = absoluteUrl baseUrl (drop 2 path)+ let pageDate = parseMay datePrefix (baseName path)+ let pageTitle = mkTitle content let pageContent = render content return Page{..}- where++mkTitle :: TL.Text -> TL.Text+mkTitle content = TL.filter (not . isMarkdownChar) (TL.takeWhile isNotNewLine content)+ where isMarkdownChar ch = ch == '_' || ch == '*' || ch == '#' || ch == '>' isNotNewLine ch = ch /= '\n' && ch /= '\r' @@ -45,3 +58,15 @@ render :: TL.Text -> TL.Text render = renderHtml . markdown def++parseMay :: P.Parser a -> String -> Maybe a+parseMay p src = case P.parse p "" src of+ Left _ -> Nothing+ Right x -> Just x++baseName :: FilePath -> FilePath+baseName path = basename+ where+ revPath = reverse path+ revName = takeWhile (/= '/') revPath+ basename = reverse (dropWhile (/= '.') revName)
+ library/Stagen/JsonFeed.hs view
@@ -0,0 +1,53 @@+module Stagen.JsonFeed where++import qualified Data.ByteString.Lazy as BL+import Data.Aeson (Value(String))+import Data.Text (Text)+import Data.Text.Conversions (fromText, toText)+import Network.URI+import JsonFeed++import Stagen.Page++createJsonFeed :: String -> String -> [Page] -> BL.ByteString+createJsonFeed title baseUrl pages = let+ feed = mkFeed (toText title) (toText baseUrl)+ feed' = feed { feedItems = map toItem pages }+ in renderFeed feed'++mkFeed :: Text -> Text -> Feed+mkFeed title baseUrl = Feed+ { feedAuthor = Nothing+ , feedDescription = Nothing+ , feedExpired = Nothing+ , feedFavicon = Nothing+ , feedFeedUrl = fmap (\uri -> Url $ uri { uriPath = (uriPath uri) ++ "/feed.json" }) baseUri+ , feedHomePageUrl = fmap Url baseUri+ , feedHubs = Nothing+ , feedIcon = Nothing+ , feedItems = []+ , feedNextUrl = Nothing+ , feedTitle = title+ , feedUserComment = Nothing+ , feedVersion = Url $ URI "https:" (Just $ URIAuth "" "jsonfeed.org" "") "/version/1" "" ""+ }+ where+ baseUri = parseURI (fromText baseUrl)++toItem :: Page -> Item+toItem page = Item+ { itemAttachments = Nothing+ , itemAuthor = Nothing+ , itemBannerImage = Nothing+ , itemContentHtml = Nothing+ , itemContentText = Nothing+ , itemDateModified = Nothing+ , itemDatePublished = Nothing+ , itemExternalUrl = Nothing+ , itemId = String (toText (pageAbsoluteUrl page))+ , itemImage = Nothing+ , itemSummary = Nothing+ , itemTags = Nothing+ , itemTitle = Just (toText (pageTitle page))+ , itemUrl = fmap Url $ parseURI (fromText $ toText (pageAbsoluteUrl page))+ }
library/Stagen/Opts.hs view
@@ -1,6 +1,5 @@ module Stagen.Opts where -import qualified Data.Text.Lazy as TL import Data.Default import Data.Bool (bool) import Data.Monoid (mconcat, (<>))@@ -26,6 +25,8 @@ optsIgnore :: [FilePath], optsJobs :: Int, optsVerbose :: Verbose,+ optsBaseUrl :: FilePath,+ optsTitle :: String, optsTargetDirectory :: TargetDirectory } deriving Show @@ -49,6 +50,8 @@ <*> many (strArg 'i' "ignore" "Don't render this file") <*> (option auto (arg 'j' "jobs" "Run ARG jobs simultaneously") <|> pure (optsJobs def)) <*> fmap (bool Slient Verbose) (switch (arg 'v' "verbose" "Explain what is being done"))+ <*> strArg 'u' "url" "Base url for the generated pages"+ <*> strArg 't' "title" "Title of the blog" <*> targetDirectory arg :: HasName f => Char -> String -> String -> Mod f a@@ -64,4 +67,4 @@ targetDirectory = strArgument (metavar "TARGET_DIRECTORY") <|> pure (optsTargetDirectory def) instance Default Opts where- def = Opts Build Nothing Nothing Nothing Nothing [] [] [] 1 Slient "."+ def = Opts Build Nothing Nothing Nothing Nothing [] [] [] 1 Slient "" "" "."
library/Stagen/Page.hs view
@@ -2,11 +2,14 @@ import qualified Data.Text.Lazy as TL import Data.Default+import Stagen.Date data Page = Page {+ pageAbsoluteUrl :: TL.Text,+ pageDate :: Maybe Date, pageTitle :: TL.Text, pageContent :: TL.Text } deriving Show instance Default Page where- def = Page TL.empty TL.empty+ def = Page TL.empty Nothing TL.empty TL.empty
+ library/Stagen/RssFeed.hs view
@@ -0,0 +1,55 @@+module Stagen.RssFeed where++import qualified Data.Text.Lazy as TL+import qualified Text.RSS.Syntax as Rss+import qualified Text.RSS.Export as Export++import Prelude ()+import Prelude.Compat hiding (take)+import Data.Text hiding (map)+import Data.Text.Conversions (toText)+import Data.Text.Lazy (toStrict)+import Data.XML.Types as XML+import Text.XML as C+import Data.Maybe++import Stagen.Date+import Stagen.Page++createRssFeed :: String -> FilePath -> [Page] -> Maybe TL.Text+createRssFeed title baseUrl+ = fmap TL.fromStrict+ . feed title baseUrl+ . catMaybes+ . map (\page -> case pageDate page of+ Nothing -> Nothing+ Just date -> Just (toDateString date, toStrict $ pageAbsoluteUrl page, toStrict $ pageTitle page))++toDateString :: Date -> Rss.DateString+toDateString Date{dateYear,dateMonth,dateDay} = toText $ mconcat+ [ show dateYear+ , "-"+ , showTwoDigits dateMonth+ , "-"+ , showTwoDigits dateDay+ , "T00:00:00Z"+ ]++feed :: String -> FilePath -> [(Rss.DateString, Rss.URLString, Text)] -> Maybe Text+feed blogTitle baseUrl posts = fmap (toStrict . renderText def) $ elementToDoc $ Export.xmlRSS $ fd+ where+ fd :: Rss.RSS+ fd =+ (Rss.nullRSS+ (toText blogTitle) -- Title+ (toText $ baseUrl ++ "/rss.xml")) -- ID+ { Rss.rssChannel = (Rss.nullChannel (toText blogTitle) (toText baseUrl))+ { Rss.rssItems = map+ (\(date, url, title) -> (Rss.nullItem title) { Rss.rssItemLink = Just url, Rss.rssItemPubDate = Just date })+ posts+ }+ }++elementToDoc :: XML.Element -> Maybe C.Document+elementToDoc el =+ either (const Nothing) Just $ fromXMLDocument $ XML.Document (Prologue [] Nothing []) el []
package.yaml view
@@ -1,5 +1,5 @@ name: stagen-version: '0.1.0'+version: '0.2.0' category: Web synopsis: Static site generator description: Low dependency static site generator using markdown@@ -14,10 +14,12 @@ - OverloadedStrings - TupleSections - RecordWildCards+- NamedFieldPuns library: dependencies: - aeson - base >= 4.7 && < 5+ - base-compat - bytestring - blaze-html - data-default@@ -29,7 +31,14 @@ - optparse-applicative - parallel - parsec+ - json-feed - text+ - text-conversions+ - feed+ - network-uri+ - xml+ - xml-conduit+ - xml-types source-dirs: library executables: stagen:
stagen.cabal view
@@ -1,9 +1,11 @@--- This file has been generated from package.yaml by hpack version 0.17.1.+-- This file has been generated from package.yaml by hpack version 0.20.0. -- -- see: https://github.com/sol/hpack+--+-- hash: badead40d64f903a9c62f6a773f8e419930b97d6e7c489d699eec49dcdf7f9e7 name: stagen-version: 0.1.0+version: 0.2.0 synopsis: Static site generator description: Low dependency static site generator using markdown category: Web@@ -20,43 +22,58 @@ library hs-source-dirs: library- default-extensions: LambdaCase OverloadedStrings TupleSections RecordWildCards+ default-extensions: LambdaCase OverloadedStrings TupleSections RecordWildCards NamedFieldPuns ghc-options: -Wall build-depends: aeson- , base >= 4.7 && < 5- , bytestring+ , base >=4.7 && <5+ , base-compat , blaze-html+ , bytestring , data-default , directory+ , feed , filemanip+ , json-feed , lucid , markdown , mtl+ , network-uri , optparse-applicative , parallel , parsec , text+ , text-conversions+ , xml+ , xml-conduit+ , xml-types exposed-modules:+ Stagen.AtomFeed Stagen.Build Stagen.Clean Stagen.Date Stagen.File Stagen.Init Stagen.Job+ Stagen.JsonFeed Stagen.Main Stagen.Opts Stagen.Page+ Stagen.RssFeed Stagen.Template+ other-modules:+ Paths_stagen default-language: Haskell2010 executable stagen main-is: Main.hs hs-source-dirs: executable- default-extensions: LambdaCase OverloadedStrings TupleSections RecordWildCards+ default-extensions: LambdaCase OverloadedStrings TupleSections RecordWildCards NamedFieldPuns ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N build-depends: base , stagen+ other-modules:+ Paths_stagen default-language: Haskell2010