repo-based-blog (empty) → 0.0.1
raw patch · 24 files changed
+1560/−0 lines, 24 filesdep +QuickCheckdep +basedep +blaze-htmlsetup-changed
Dependencies added: QuickCheck, base, blaze-html, containers, data-default, directory, dyre, filepath, filestore, hspec, hspec-discover, ixset, lens, mtl, old-locale, pandoc, parsec, repo-based-blog, stm, text, time, transformers, transformers-base, transformers-compat
Files
- LICENSE +28/−0
- README.md +26/−0
- Setup.hs +2/−0
- changelog.md +8/−0
- executable/Main.hs +33/−0
- library/Web/RBB.hs +210/−0
- library/Web/RBB/Blog.hs +111/−0
- library/Web/RBB/Blog/Query.hs +80/−0
- library/Web/RBB/Config.hs +48/−0
- library/Web/RBB/Converter.hs +89/−0
- library/Web/RBB/Crawler.hs +18/−0
- library/Web/RBB/Crawler/MetaCombiner.hs +73/−0
- library/Web/RBB/Crawler/MetaParser.hs +147/−0
- library/Web/RBB/Crawler/Repository.hs +178/−0
- library/Web/RBB/Main.hs +32/−0
- library/Web/RBB/Templates/Default.hs +83/−0
- library/Web/RBB/Types.hs +17/−0
- library/Web/RBB/Types/Blog.hs +38/−0
- library/Web/RBB/Types/CachedEntry.hs +23/−0
- library/Web/RBB/Types/Entry.hs +121/−0
- library/Web/RBB/Types/FileType.hs +37/−0
- library/Web/RBB/Util.hs +38/−0
- repo-based-blog.cabal +119/−0
- test-suite/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2014, Sebastian Witte+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 saeplog nor the names of its+ 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 HOLDER 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.+
+ README.md view
@@ -0,0 +1,26 @@+++# repo-based-blog++A blogging module that uses a repository as its content backend.++# Usage++The Haddock documentation of the module `Web.RBB` should contain enough+information to get started.++# Contributing++As long as there are no web application specific changes required, I would+usually just review and accept every pull request.++## Guidelines++* Please write documentation!+* Please try to write tests!+* If an issue exists, reference it!+* Similar to neovim's development, use [WIP], [RFC] and [RDY] as tags in+ pull requests. Especially the [WIP] annotation has the potential to avoid+ unnecessary duplicate work if the pull request is created immediately+ after starting to work at the issue.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ changelog.md view
@@ -0,0 +1,8 @@+# Version 0.0.1 (2014-11-14)++* Allows a dyre-based blog configuration+ (see haddock in `Web.RBB` for an example)++| --+| Sebastian Witte <woozletoff@gmail.com>+
+ executable/Main.hs view
@@ -0,0 +1,33 @@+{- |+Module : Main+Description : Saeplog web server+Copyright : (c) Sebastian Witte+License : BSD3++Maintainer : woozletoff@gmail.com+Stability : experimental++-}+module Main where++import System.Exit+import System.IO+import Web.RBB (rbb)++main :: IO ()+main = rbb $ do+ mapM_ (hPutStrLn stderr)+ [ ""+ , "You do not seem to have configured your web site at all!"+ , ""+ , "As you should decide how your site is going to look like, the"+ , "default configuration does not do anything other than printing"+ , "this help text."+ , ""+ , "To get you started on creating your own website with haskell and"+ , "this blogging library, check out the documentation on github:"+ , " https://github.com/saep/repo-based-blog"+ , ""+ ]+ exitFailure+
+ library/Web/RBB.hs view
@@ -0,0 +1,210 @@+{- |+Module : Web.RBB+Description : This module re-exports all necessary and some useful modules+Copyright : (c) Sebastian Witte+License : BSD3++Maintainer : woozletoff@gmail.com+Stability : experimental++-}+module Web.RBB (+ -- * Configuration+ -- $configuration+ BlogConfig (..),+ createDefaultBlogConfig,++ -- * Usage+ -- ** General+ -- $usage+ Blog,+ getBlogConfig,+ withBlog,+ blogEntries,++ -- ** XMonad style usage+ -- $example+ rbb,++ -- * Entry querying+ -- ** Entry+ Entry,+ entryId,+ -- | Unique 'Entry' identifier. It you do not mess with the repositories+ -- history, this should be the same across restarts.+ title,+ -- | Title of the 'Entry'.+ author,+ -- | Author of the 'Entry'.+ authorEmail,+ tags,+ fileType,++ -- $ixsetquery+ Title(..),+ AuthorName(..),+ AuthorEmail(..),+ Tags(..),+ Index(..),++ -- ** FileType+ FileType(..),++ def,+ ) where++import Data.Default (Default (..))+import Web.RBB.Blog (Blog, blogEntries, getBlogConfig, withBlog)+import Web.RBB.Config (BlogConfig (..))+import Web.RBB.Main (rbb)+import Web.RBB.Templates.Default (createDefaultBlogConfig)+import Web.RBB.Types.Entry+import Web.RBB.Types.FileType (FileType (..))++-- $configuration+-- The blog configuration is essentially done by setting the fields of the+-- 'BlogConfig' data type. A basic configuration can be created with the+-- function 'createDefaultBlogConfig' that only takes the absolutely necessary+-- parameters.++-- $usage+-- To use the blog in an web application, you have to create an abstact 'Blog'+-- value via the 'withBlog' function and pass it to functions that need access+-- to it because they call blog related functions.+--+-- > importWeb.RBB+-- >+-- > myBlogConfig = createDefaultBlogConfig+-- > "/path/to/repository/with/blog/entries"+-- > "/path/to/folder/with/static/resources"+-- >+-- > main = withBlog myBlogConfig $ \blog -> do+-- > putStrLn "Replace this with your web application code."++-- $example+--+-- You can also define an xmonad-like configuration for your blog. If the few+-- functions from this module do not give you a basic idea on how to use this+-- library, a trivial example will not suffice.+-- The following example will contain two modules and for the sake of this+-- example, I will assume that the configuration is in+-- @~\/.config\/repo-based-blog@.+--+-- The first file is @repo-based-blog.hs@. It will containt the markup and a+-- minimal happstack server example. The blog will be present at+-- <http://127.0.0.1:8000>.+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > import Web.RBB+-- >+-- > import Query+-- >+-- > import Text.Blaze.Html5 as H+-- > import Control.Applicative ((<$>), optional)+-- > import Control.Monad+-- > import Control.Monad.IO.Class+-- > import Data.Text (Text, unpack)+-- > import Happstack.Server+-- > import Data.Maybe+-- > import qualified Data.IxSet as IxSet+-- > import System.Directory+-- > import Text.Blaze.Html5.Attributes as A hiding (dir, start, id)+-- > import Happstack.Server (Conf (port), notFound, nullConf, toResponse, simpleHTTP)+-- >+-- > siteTemplate :: (Monad m, Functor m)+-- > => [Html] -- ^ Additional Headers+-- > -> [Html] -- ^ Body content+-- > -> m Html+-- > siteTemplate hs bodyContent = return $ do+-- > docType+-- > html $ do+-- > H.head $ do+-- > meta ! httpEquiv "Content-Type"+-- > ! content "text/html;charset=utf-8"+-- > meta ! content "width=device-width, initial-scale=1, maximum-scale=1"+-- > ! name "viewport"+-- > link ! rel "stylesheet" ! type_ "text/css"+-- > ! href "resources/default.css"+-- > sequence_ hs+-- > H.body $ do+-- > topNavigationBar [ ("Blog", Just "?")+-- > , ("Github", Just "https://github.com/saep")+-- > ]+-- > sequence_ bodyContent+-- >+-- > topNavigationBar :: [(Html, Maybe String)] -> Html+-- > topNavigationBar [] = return ()+-- > topNavigationBar xs =+-- > H.div ! class_ "horiz-nav" $+-- > H.nav ! A.class_ "horiz-nav" $+-- > ul ! class_ "horiz-nav" $+-- > forM_ xs $ \(t, ml) ->+-- > case ml of+-- > Just l -> li $ a ! href (toValue l) $ t+-- > _ -> li t+-- >+-- > serveBlog :: Blog (ServerPartT IO)+-- > -> ServerPartT IO Response+-- > serveBlog blog = do+-- > qd <- parseQueryRqData+-- > mId <- join . fmap readMaybe <$> optional (look "id")+-- > let qfun = fmap (IxSet.getEQ . Index) mId+-- > entries <- join $ blogEntries blog qd qfun+-- > blogMarkup <- siteTemplate hs [entries]+-- > ok . toResponse $ blogMarkup -- happstack specific+-- > where+-- > hs = [ H.title "Saeptain's log" ]+-- >+-- > myBlogConfig :: BlogConfig (ServerPartT IO)+-- > myBlogConfig =+-- > let cfg = createDefaultBlogConfig "/home/saep/git/myblog"+-- > in cfg { baseURL = return "http://127.0.0.1:8000/blog" }+-- >+-- > main :: IO ()+-- > main = rbb $ withBlog myBlogConfig $ \b -> do+-- > liftIO $ simpleHTTP (nullConf { port = 8000 }) $ msum+-- > [ dir "resources" $ serveDirectory DisableBrowsing [] "/home/saep/git/blog/resources"+-- > , serveBlog b+-- > , notFound $ toResponse ()+-- > ]+--+-- The Query module, which you will be missing apart from the obvious missing+-- libraries is located in @lib/Query.hs@+--+-- > module Query where+-- >+-- > import Happstack.Server (look, HasRqData, ServerPartT)+-- > import Web.RBB.Blog.Query+-- > import Control.Applicative+-- > import Data.Maybe+-- >+-- > readMaybe :: Read a => String -> Maybe a+-- > readMaybe x = case reads x of+-- > [(v,_)] -> Just v+-- > _ -> Nothing+-- >+-- > -- | 'look' at the request data of the given name and try to parse it via+-- > -- 'readMaybe'. If the parse failed or the request data did not exist, return+-- > -- the provided default.+-- > maybeLookAndRead :: (Monad m, Read a, Alternative m, HasRqData m)+-- > => a -> String -> m a+-- > maybeLookAndRead a qry = do+-- > l <- optional $ look qry+-- > return $ fromMaybe a (maybe (Just a) readMaybe l)+-- >+-- > -- | Parse the supported request data and present it in a data type.+-- > parseQueryRqData :: ServerPartT IO EntryQuery+-- > parseQueryRqData = EntryQuery+-- > <$> (sortMethodToComparator+-- > <$> maybeLookAndRead Update "sortBy"+-- > <*> maybeLookAndRead Descending "sortOrder")++++-- $ixsetquery+-- These newtype wrappers are used by the 'IxSet' of 'Entry' values and needed+-- for search queries.+--+-- > queryEntryForIdentifier :: Ixset Entry -> Maybe Entry+-- > queryEntryForIdentifier set = getOne $ set @= Index 42+--
+ library/Web/RBB/Blog.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE FlexibleContexts #-}+{- |+Module : Web.RBB.Blog+Description : Very experimental Blog-serving facilties+Copyright : (c) Sebastian Witte+License : BSD3++Maintainer : woozletoff@gmail.com+Stability : experimental++-}+module Web.RBB.Blog+ ( withBlog+ , blogEntries+ , Blog+ , getBlogConfig+ ) where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad.Reader+import Control.Monad.Trans.Except+import Data.IxSet (toList)+import Data.List (sortBy)+import qualified Data.Map as Map+import Data.Time+import System.Exit (exitFailure)+import System.IO+import Web.RBB.Blog.Query+import Web.RBB.Config+import Web.RBB.Converter (renderEntries)+import Web.RBB.Crawler+import Web.RBB.Types.Blog hiding (Blog)+import qualified Web.RBB.Types.Blog as Internal+import Web.RBB.Types.CachedEntry+import Web.RBB.Types.Entry+import Web.RBB.Util++-- | A value of this type contains all the data needed for the blog module to+-- operate.+newtype Blog m = Blog (Maybe (TVar (Internal.Blog m)))+-- TODO saep 2014-11-09 remove the Maybe wrapper?++-- | Retrieve the 'BlogConfig' from the 'Blog' value. Due to the resuorce+-- managmeent that the 'Blog' data type encapsulates, this function only works+-- inside an 'IO' monad.+getBlogConfig :: (Functor io, MonadIO io)+ => Blog m -> io (Maybe (BlogConfig m))+getBlogConfig (Blog Nothing) = return Nothing+getBlogConfig (Blog (Just blog)) = Just . view blogConfig <$> liftIO (readTVarIO blog)++-- | Create a 'Blog' object by providing a 'BlogConfig' value.+-- This function also starts threads which will handle the resource management+-- with some configurable settings that can be defined in the 'BlogConfig'.+withBlog :: BlogConfig m -> (Blog m -> IO ()) -> IO ()+withBlog cfg action = do+ mb <- runExceptT $ initBlog cfg+ case mb of+ Left err -> do+ hPutStrLn stderr err+ exitFailure+ Right b -> do+ tb <- atomically $ newTVar b+ _ <- forkIO $ manageEntryCache tb (b^.blogCacheChannel)+ action $ Blog (Just tb)++-- | Retrieve an 'IxSet' of blog 'Entry' values. If+blogEntries :: (Functor io, MonadIO io, Monad m)+ => Blog m -- ^ Blog configuration+ -> EntryQuery -- ^ Sorting order of the entries+ -> Maybe (IxSet Entry -> IxSet Entry) -- ^ Query function+ -> io (m Html)+blogEntries (Blog Nothing) _ _ = return $ return mempty+blogEntries (Blog (Just tb)) eq qfun = do+ _ <- liftIO . forkIO $ manageEntryUpdates tb+ b <- liftIO $ readTVarIO tb+ let es = toList . fromMaybe id qfun $ b^.entries+ renderEntries b $ sortBy (eqSortBy eq) es+++-- | On a site rendering request, test whether the entry repository should+-- check for updates.+manageEntryUpdates :: TVar (Internal.Blog m) -> IO ()+manageEntryUpdates tb = do+ b <- liftIO $ readTVarIO tb+ let luc = b^.lastUpdateCheck+ now <- liftIO getCurrentTime+ let interval = max 1 . fromInteger . updateInterval $ b^.blogConfig+ shouldCheckForUpdate <- liftIO . atomically $ updateUpdateTime now luc interval+ when shouldCheckForUpdate $ do+ blog <- liftIO $ readTVarIO tb+ u <- runExceptT $ updateBlog blog+ case u of+ Left err -> hPutStrLn stderr err+ Right blog' -> liftIO . atomically $ writeTVar tb blog'++ where+ updateUpdateTime :: UTCTime -> UTCTime -> NominalDiffTime-> STM Bool+ updateUpdateTime now luc interval+ | diffUTCTime now luc > interval * 60 {- seconds -} = do+ modifyTVar tb $ lastUpdateCheck .~ now+ return True+ | otherwise = return False+++manageEntryCache :: TVar (Internal.Blog m) -> TChan (Integer, CachedEntry) -> IO ()+manageEntryCache tb tc = forever $ do+ (i,h) <- atomically $ readTChan tc+ atomically . modifyTVar tb $ blogEntryCache %~ Map.insert i h++
+ library/Web/RBB/Blog/Query.hs view
@@ -0,0 +1,80 @@+{- |+Module : Web.RBB.Blog.Query+Description : Utlities for creating search queries+Copyright : (c) Sebastian Witte+License : BSD3++Maintainer : woozletoff@gmail.com+Stability : experimental++This module provides some functions and data types that can be used to manage+search and query data for a list of 'Entry' values.+-}+module Web.RBB.Blog.Query (+ EntryQuery(..),++ -- * Sorting+ SortMethod(..),+ SortOrder(..),+ sortMethodToComparator,++ ) where++import Data.Default+import Web.RBB.Types+import Web.RBB.Util+++-- | Simple enum that provides Show and read instances so that a parser can+-- convert the sting directly to a value of this type.+data SortMethod = Update | Identifier | Author+ deriving (Show, Read, Eq, Ord, Enum)++data SortOrder = Ascending | Descending+ deriving (Show, Read, Eq, Ord, Enum)+++-- | Convert a 'SortMethod' value to a sorting function that can be used in+-- confunction with functions 'sortBy' from "Data.List".+sortMethodToComparator :: SortMethod -> SortOrder -> (Entry -> Entry -> Ordering)+sortMethodToComparator m o+ | o == Ascending = cmp+ | otherwise = flip cmp+ where+ cmp = case m of+ Update -> compare `on` view lastUpdate+ Identifier -> compare `on` view entryId+ Author -> compare `on` view author+++-- | The request data provided inside a URL.+--+-- Example: @?id=42&sortBy=Identifier@+--+-- Example backend implementation using the Happstack package:+--+-- > import Happstack.Server (look, HasRqData, ServerPartT)+-- >+-- > maybeLookAndRead :: (Monad m, Read a, Alternative m, HasRqData m)+-- > => a -> String -> m a+-- > maybeLookAndRead a qry = do+-- > l <- optional $ look qry+-- > return $ fromMaybe a (maybe (Just a) readMaybe l)+-- >+-- > -- | Parse the supported request data and present it in a data type.+-- > parseQueryRqData :: ServerPartT IO EntryQuery+-- > parseQueryRqData = EntryQuery+-- > <$> (sortMethodToComparator+-- > <$> maybeLookAndRead Update "sortBy"+-- > <*> maybeLookAndRead Descending "sortOrder")+-- >+data EntryQuery = EntryQuery+ { eqSortBy :: Entry -> Entry -> Ordering+ -- ^ The method entries are sorted by.+ }++-- | The 'Default' instance for an 'EntryQuery' type contains a function that+-- sorts the entries descending by the last update to the entry.+instance Default EntryQuery where+ def = EntryQuery (sortMethodToComparator Update Descending)+
+ library/Web/RBB/Config.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}+{- |+Module : Web.RBB.Config+Description : Basic configuration for a blog+Copyright : (c) Sebastian Witte+License : BSD3++Maintainer : woozletoff@gmail.com+Stability : experimental++-}+module Web.RBB.Config+ ( BlogConfig(..)+ ) where++import Data.Text (Text)+import Data.Time (UTCTime)+import Text.Blaze.Html5 (Html)+import Web.RBB.Types++-- | Basic configuration of the blog.+-- The @m@ type variable is just a context in which the functions can operate+-- on. It can be as simple as the @Identity@ functor but also more complex to+-- play nice with libraries such as boomerang (which provides type-safe URLs).+-- These functions are usually called in an 'IO' context and hence the context+-- can be some 'IO' type as well.+--+data BlogConfig m = BlogConfig+ { baseURL :: m Text+ -- ^ The base URL of the website such as+ -- <https://github.com/saep/repo-based-blog>.+ , entryRenderer :: BlogConfig m -> [(Entry, Html)] -> m Html+ -- ^ This field describes how the content of a blog entry is being+ -- rendered. The 'Html' content is the blog content rendered with the+ -- pandoc library. You can take a look at the implementation of the the+ -- module "RBB.Templates.Default" on how to define this function.+ --+ , timeFormatter :: UTCTime -> Text+ -- ^ Function that converts time entries to printable 'Text'.+ , entryPath :: FilePath+ -- ^ Path to the repository that contains the blog entries.+ --+ -- The path may as well point to a directory within a repository.+ , updateInterval :: Integer+ -- ^ Interval in minutes at which the entry repository should be queried for+ -- new content. Will default to 10 for entries smaller than 1.+ }+
+ library/Web/RBB/Converter.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE OverloadedStrings #-}+{- |+Module : Web.RBB.Converter+Description : Converter functions+Copyright : (c) Sebastian Witte+License : BSD3++Maintainer : woozletoff@gmail.com+Stability : experimental+++-}+module Web.RBB.Converter+ ( convertToHTML+ , fileContentToHtml+ , renderEntries+ ) where++import Control.Applicative+import Control.Concurrent.STM+import Control.Lens+import Control.Monad.IO.Class+import Control.Monad.Reader+import Data.Default+import qualified Data.Map as Map+import qualified Data.Set as Set+import Text.Pandoc.Options+import Text.Pandoc.Readers.Markdown+import Text.Pandoc.Writers.HTML+import Web.RBB.Config+import Web.RBB.Types as E+import Web.RBB.Types.Blog+import Web.RBB.Types.CachedEntry as E+import Web.RBB.Util++-- | Given a bunch of entries and a 'Blog'+renderEntries :: (Functor io, MonadIO io, Monad m)+ => Blog m -> [Entry] -> io (m Html)+renderEntries blog is = do+ cachedEntries <- foldM manageCache [] $ select is+ let bcfg = blog^.blogConfig+ return . entryRenderer bcfg bcfg $ reverse cachedEntries+ where+ select :: [Entry] -> [(Maybe CachedEntry, Maybe Entry)]+ select =+ let c = blog^.blogEntryCache+ in map (\e -> (Map.lookup (e^.entryId) c, Just e))++ manageCache :: (Functor io, MonadIO io)+ => [(Entry, Html)]+ -> (Maybe CachedEntry, Maybe Entry)+ -> io [(Entry, Html)]+ manageCache acc ie =+ case ie of+ (_,Nothing) -> return acc+ (Just ce, Just e) | ((==) `on` updateTime) (ce^.cacheEntryData) e+ -> return $ (ce^.cacheEntryData, ce^.entry) : acc+ (_, Just e) -> do+ en <- convertToHTML e <$> liftIO (readFile (e^.fullPath))+ let h = CachedEntry en (e^.lastUpdate) e+ liftIO . atomically $+ writeTChan (blog^.blogCacheChannel) (e^.entryId, h)+ return $ (e, en) : acc+ where+ updateTime e = entryUpdateTime (e^.lastUpdate)++-- | Converter function that choses an appropriate pandoc configuration for the+-- given 'FileType' and converts the given 'String' to 'Html'.+fileContentToHtml :: FileType -> String -> Html+fileContentToHtml ft = writeHtml defaultWriter . case ft of+ PandocMarkdown ->+ readMarkdown (def+ { readerExtensions = pandocExtensions })+ LiterateHaskell ->+ readMarkdown (def+ { readerExtensions = Ext_literate_haskell `Set.insert` pandocExtensions })++-- | Convert the given file contents given as a 'String' to an 'Html' element+-- and add some meta data from the 'EntryData' argument'.+convertToHTML :: Entry -> String -> Html+convertToHTML ed = fileContentToHtml (ed^.fileType)++-- | Default 'WriterOptions' for the converters.+defaultWriter :: WriterOptions+defaultWriter = def+ { writerHtml5 = True+ , writerEmailObfuscation = ReferenceObfuscation+ , writerHighlight = True+ }
+ library/Web/RBB/Crawler.hs view
@@ -0,0 +1,18 @@+{- |+Module : Web.RBB.Crawler+Description : Exported Crawler API+Copyright : (c) Sebastian Witte+License : BSD3++Maintainer : woozletoff@gmail.com+Stability : experimental++-}+module Web.RBB.Crawler+ ( module Web.RBB.Crawler.MetaParser+ , module Web.RBB.Crawler.Repository+ ) where++import Web.RBB.Crawler.MetaParser (Meta (..), parseMeta)+import Web.RBB.Crawler.Repository (initBlog, updateBlog)+
+ library/Web/RBB/Crawler/MetaCombiner.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE TemplateHaskell #-}+{- |+Module : Web.RBB.Crawler.MetaCombiner+Description : Contract a list of meta data into a single value type+Copyright : (c) Sebastian Witte+License : BSD3++Maintainer : woozletoff@gmail.com+Stability : experimental++-}+module Web.RBB.Crawler.MetaCombiner+ where++import Control.Lens hiding (Context)+import Control.Monad.State+import Data.IxSet hiding (null)+import qualified Data.IxSet as IxSet+import Data.Monoid+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import Web.RBB.Crawler.MetaParser as M+import Web.RBB.Types.Entry++data MetaDataContractionState = S+ { _context :: Maybe FilePath+ , _metaDataMap :: IxSet Entry+ }+makeLenses ''MetaDataContractionState++-- | Add the given meta information to the giten 'IxSet'.+contract :: Maybe FilePath -- ^ Content relative path for an 'Entry'+ -> [Meta] -- ^ Parsed meta information to add+ -> IxSet Entry -- ^ Original entry 'IxSet'+ -> IxSet Entry+contract initialContext meta m =+ let initialState = S initialContext m+ in execState (mapM_ contract' meta) initialState ^. metaDataMap++contract' :: Meta -> State MetaDataContractionState ()+contract' (Context c) = context .= Just c+contract' None = return ()+contract' meta = maybe (return ()) (updateMetaData meta) =<< use context++updateMetaDataMap :: FilePath+ -> (Entry -> Entry)+ -> State MetaDataContractionState ()+updateMetaDataMap c f = do+ m <- use metaDataMap+ let ixC = RelativePath c+ case getOne $ m @= ixC of+ Nothing -> return ()+ Just e -> do+ metaDataMap %= IxSet.deleteIx ixC+ metaDataMap %= IxSet.insert (f e)++updateMetaData :: Meta -> FilePath -> State MetaDataContractionState ()+updateMetaData meta c = case meta of+ M.Tags ts -> updateMetaDataMap c $ tags %~ updateTags ts+ ~(M.Title t) -> updateMetaDataMap c $ title .~ t++updateTags :: [(TagQuantifier, Text)] -> Set Text -> Set Text+updateTags ts tset+ | null reps = foldr update tset ts+ | otherwise = foldr update mempty ts+ where+ reps = filter ((== TagReplace) . fst) ts++ update (TagRemove, t) = Set.delete t+ update (_, t) = Set.insert t++
+ library/Web/RBB/Crawler/MetaParser.hs view
@@ -0,0 +1,147 @@+{- |+Module : Web.RBB.Crawler.MetaParser+Description : Extract meta data from the repository+Copyright : (c) Sebastian Witte+License : BSD3++Maintainer : woozletoff@gmail.com+Stability : experimental++-}+module Web.RBB.Crawler.MetaParser+ where++import Control.Applicative (pure, (*>), (<$>), (<*), (<*>))+import Control.Monad+import Data.Char+import Data.Text (Text, pack)+import Text.Parsec++-- | The 'Meta' data type represents a model of all the meta data that can be+-- embedded into a commit.+data Meta =+ Tags [(TagQuantifier, Text)]+ -- ^ $tag+ | Title Text+ -- ^ $title+ | Context FilePath+ -- ^ Context entry, usually a relative path for the blog entry repository.+ --+ -- There is no validity check performed.+ | None+ -- ^ Everything that is not a tag quantified in pieces of text followed by+ -- two newlines or the end of input.+ deriving (Eq, Show)++-- | Data type representing a the prefix of a tag.+data TagQuantifier+ = TagAdd+ -- ^ Add the tag to the current set of tags.+ | TagRemove+ -- ^ Remove the tag from the current set of tags.+ | TagReplace+ -- ^ Replace the current set of tags with all the tags given in this tag+ -- definition.+ deriving (Eq, Show, Read, Ord, Enum, Bounded)++-- | Helper parser for a case-insensitive character.+ciChar :: Char -> Parsec String u Char+ciChar c = char (toLower c) <|> char (toUpper c)++-- | Helper parser for a case-insensitive string.+ciString :: String -> Parsec String u String+ciString = mapM ciChar++-- | Parse meta data from the given 'String'. The order of the list items is+-- the same as the order in which the meta data appears in the input.+parseMeta :: String -> Either ParseError [Meta]+parseMeta inp =+ parse (many pSplice) "slice" (inp++"\n\n")+ >>= mapM (parse pMeta "meta parser") . filter (not . all isSpace)++pSplice :: Parsec String u String+pSplice = blankLines+ <|> unwords . words . unlines <$> many1 (notFollowedBy blankLine *> anyLine)++skipSpaces :: Parsec String u ()+skipSpaces = skipMany $ char ' ' <|> char '\t'++blankLine :: Parsec String u Char+blankLine = skipSpaces *> newline++blankLines :: Parsec String u String+blankLines = many1 blankLine++anyLine :: Parsec String u String+anyLine = skipSpaces *> (anyChar `manyTill` newline)++pMeta :: Parsec String u Meta+pMeta = try pTags <|> try pTitle <|> try pContext <|> pNone++pNone :: Parsec String u Meta+pNone = const None <$> many1 anyChar++-- $tag+--+-- A tag can be applied to any published document. For now they are associated+-- with the changed files of a commit. This means that you have to edit a file+-- in order to make update the tags. (Adding/Removing an empty line at the end+-- will do.) This limitation lies within the technical choice of meta data+-- representation. In the future, features from within the blog could be used to+-- do such simple tasks.+--+-- The sytax of tags is quite simple:+-- @tag[s]:@ in any case followed by a space or newline separated list of tags.+-- Tags which spaces can be escaped with quotation marks.+--+-- >>> parseMeta "tAgS : foo \"bar'mitz wa\" +'quz''"+--+-- Tags can also be prefixed with @+@ or @-@. If only tags with a prefix are+-- used, they will be added or removed from the current state of the blog's+-- entry. However, if at leas one of the provided tags has no prefix, the tags+-- will be overwritten by the given tags.+--++pTags :: Parsec String u Meta+pTags = Tags+ <$> (try (ciString "tag" *> optional (ciChar 's') *> try spaces *> char ':')+ *> spaces *> pSpaceElements <* spaces)++pQuantifierPrefix :: Parsec String u TagQuantifier+pQuantifierPrefix = quantify <$> (try (char '+') <|> try (char '-') <|> pure '=')+ where+ quantify c+ | c == '+' = TagAdd+ | c == '-' = TagRemove+ | otherwise = TagReplace++pSpaceElements :: Parsec String u [(TagQuantifier, Text)]+pSpaceElements = many pSpaceDelimitedElement++pSpaceDelimitedElement :: Parsec String u (TagQuantifier, Text)+pSpaceDelimitedElement = (\q t -> (q, pack t))+ <$> pQuantifierPrefix+ <*> (char '"' *> anyChar `manyTill` char '"' <* tryEndOfTag+ <|> char '\'' *> anyChar `manyTill` try (char '\'' *> tryEndOfTag)+ <|> ((:) <$> satisfy (not . isSpace)+ <*> anyChar `manyTill` tryEndOfTag))++tryEndOfTag :: Parsec String u ()+tryEndOfTag = (try (void space) *> spaces) <|> eof++-- $title+-- A title is a String delimited by 2 newlines or the end of input. Newlines+-- withing the title defition are replaced by spaces.+--+-- >>> parseMeta "title: This is an example\nwith a newline within it"+--+pTitle :: Parsec String u Meta+pTitle = Title . pack . unwords+ <$> (try (ciString "title") *> spaces *> char ':' *> spaces+ *> many ((:) <$> anyChar <*> anyChar `manyTill` tryEndOfTag))++pContext :: Parsec String u Meta+pContext = Context . unwords+ <$> (try (ciString "context") *> spaces *> char ':' *> spaces+ *> many ((:) <$> anyChar <*> anyChar `manyTill` tryEndOfTag))+
+ library/Web/RBB/Crawler/Repository.hs view
@@ -0,0 +1,178 @@+{- |+Module : Web.RBB.Crawler+Description : Implementation of a meta data collector for the blog entry+ repository+Copyright : (c) Sebastian Witte+License : BSD3++Maintainer : woozletoff@gmail.com+Stability : experimental++-}+module Web.RBB.Crawler.Repository+ where++import Control.Applicative+import Control.Concurrent.STM+import Control.Lens+import Control.Monad+import Control.Monad.State+import Control.Monad.Trans.Except+import Data.FileStore (Change (..), FileStore,+ Revision (..), darcsFileStore,+ gitFileStore, mercurialFileStore)+import qualified Data.FileStore as FS+import Data.IxSet+import qualified Data.IxSet as IxSet+import Data.List (foldl')+import Data.Maybe+import Data.Monoid+import Data.Time+import System.Directory+import System.FilePath+import Web.RBB.Config+import Web.RBB.Crawler.MetaCombiner+import Web.RBB.Crawler.MetaParser+import Web.RBB.Types as E+import Web.RBB.Types.Blog+import Web.RBB.Util++-- | Initialize the 'Blog' state by providing a path inside a repository.+initBlog :: (Functor io, MonadIO io) => BlogConfig m -> ExceptT String io (Blog m)+initBlog bcfg = do+ b <- initialBlog+ collectEntryData Nothing b++ where+ initialBlog = do+ (rp, crp, fs) <- initializeFileStore (entryPath bcfg)+ Blog <$> pure 1+ <*> pure mempty+ <*> pure (EntryUpdate (UTCTime (ModifiedJulianDay 0) 0) "")+ <*> liftIO getCurrentTime+ <*> pure fs+ <*> pure mempty+ <*> (liftIO . atomically) newTChan+ <*> pure rp+ <*> pure crp+ <*> pure bcfg++-- | Update the entries in the 'Blog' state.+updateBlog :: (Functor io, MonadIO io) => Blog m -> ExceptT String io (Blog m)+updateBlog blog = collectEntryData (Just (blog^.lastEntryUpdate)) blog++collectEntryData :: (Functor io, MonadIO io)+ => Maybe EntryUpdate -- initial (Nothing) or update?+ -> Blog m+ -> ExceptT String io (Blog m)+collectEntryData eu blog =+ let interval = FS.TimeRange (entryUpdateTime <$> eu) Nothing+ fs = blog^.fileStore+ hist = FS.history fs+ notLatestKnownEntry = case entryRevisionId <$> eu of+ Nothing -> const True+ Just commit -> not . FS.idsMatch fs commit . revId+ in foldr collect blog . takeWhile notLatestKnownEntry -- . sortBy (compare `on` revDateTime)+ <$> liftIO (hist [blog^.contentRelativePath] interval Nothing)++collect :: Revision -> Blog m -> Blog m+collect r blog = foldl' go blog (revChanges r)+ where+ go b (Added fp) = maybe b (addEntry r b fp) $ fileTypeFromExtension fp+ go b (Modified fp) = maybe b (modEntry r b fp) $ fileTypeFromExtension fp+ go b (Deleted fp) = b & entries %~ IxSet.deleteIx (RelativePath fp)+ & lastEntryUpdate .~ EntryUpdate (revDateTime r) (revId r)++metaFromRevision :: Revision -> [Meta]+metaFromRevision = either (const []) id . parseMeta . revDescription++addEntry :: Revision -> Blog m -> FilePath -> FileType -> Blog m+addEntry r blog fp ft =+ let meta = metaFromRevision r+ eu = EntryUpdate (revDateTime r) (revId r)+ newEntry = Entry+ { _entryId = blog^.nextEntryId+ , E._title = (pack . takeBaseName . dropExtensions) fp+ , _author = (pack . FS.authorName . revAuthor) r+ , _authorEmail = (pack . FS.authorEmail . revAuthor) r+ , E._tags = mempty+ , _fileType = ft+ , _relativePath = fp+ , _fullPath = blog^.repositoryPath </> fp+ , _updates = fromList [eu]+ , _lastUpdate = eu+ }+ in blog & nextEntryId %~ succ+ & entries %~ contract (Just fp) meta . IxSet.insert newEntry+ & lastEntryUpdate .~ eu++modEntry :: Revision -> Blog m -> FilePath -> FileType -> Blog m+modEntry r blog fp _ =+ let meta = metaFromRevision r+ eu = EntryUpdate (revDateTime r) (revId r)+ insertUpdateTime = ixSetModifyIx (RelativePath fp) $ \e ->+ e & updates %~ IxSet.insert eu+ & lastUpdate .~ eu+ in blog & entries %~ (contract (Just fp) meta . insertUpdateTime)+ & lastEntryUpdate .~ eu++-- | Initialize a 'FileStore' object for the given directory. This function+-- should automatically detect the underlying repository type and traverse into+-- parent directories if necessary. The result is the associated 'FileStore'+-- object together with the relative path relative to the repository for the+-- blog content.+--+-- The return value is a triplet containing:+-- * The absolute path to the repository+-- * The content relative path inside the repository+-- * The associated 'FileStore' object for the repository+initializeFileStore :: (Functor io, MonadIO io)+ => FilePath+ -> ExceptT String io (FilePath, FilePath, FileStore)+initializeFileStore dir = do+ cd <- liftIO $ canonicalizePath dir+ d <- liftIO $ doesDirectoryExist cd+ unless d $ throwE $ "The directory '" ++ cd ++ "' does not exist."++ fileStores <- catMaybes `liftM` sequence+ [ lift (maybeGit cd)+ , lift (maybeDarcs cd)+ , lift (maybeMercurial cd)+ ]++ when (Prelude.null fileStores) $ throwE $ concat+ [ "The directory '", dir, "' which has been canonicalized to '"+ , cd, "' points to an unsupported repository "+ , "(includes no repository)."+ ]+ return $ head fileStores++ where++ maybeGit = maybeFileStore gitFileStore ".git"+ maybeDarcs = maybeFileStore darcsFileStore "_darcs"+ maybeMercurial = maybeFileStore mercurialFileStore ".hg"++ maybeFileStore :: (Functor io, MonadIO io)+ => (FilePath -> FileStore)+ -> FilePath+ -> FilePath+ -> io (Maybe (FilePath, FilePath, FileStore))+ maybeFileStore f qry cd =+ fmap (\p -> (cd, makeRelative p cd, f p)) <$> findDirInParents cd qry++-- | Search for a directory named as the second argument to thins function.+-- Traverse the directory tree up to the root if the directory cannot be found+-- in one of the starting directory's parent directories.+findDirInParents :: (MonadIO io) => FilePath -> FilePath -> io (Maybe FilePath)+findDirInParents dir qry = do+ adir <- normalise `liftM` liftIO (canonicalizePath dir)+ containsQry . takeWhile (not . isDrive) $ iterate takeDirectory adir++ where+ containsQry [] = return Nothing+ containsQry (d:ds) = do+ p <- liftIO $ doesDirectoryExist (d </> qry)+ case () of+ _ | p -> return $ Just d+ _ -> containsQry ds
+ library/Web/RBB/Main.hs view
@@ -0,0 +1,32 @@+{- |+Module : Web.RBB.Main+Description : Dyre wrapper+Copyright : (c) Sebastian Witte+License : BSD3++Maintainer : woozletoff@gmail.com+Stability : experimental++-}+module Web.RBB.Main+ ( rbb+ ) where++import qualified Config.Dyre as Dyre+import System.IO++-- | This function wrapping is needed to let the dyre library detect changes to+-- the configuration and recompile everything. Simply define your main in+-- @~\/.config\/repo-based-blog\/rbb.hs@ as follows:+--+-- > importWeb.RBB+-- >+-- > main = rbb $ do+-- > putStrLn "Hello, World!"+--+rbb :: IO () -> IO ()+rbb = Dyre.wrapMain $ Dyre.defaultParams+ { Dyre.projectName = "repo-based-blog"+ , Dyre.realMain = id+ , Dyre.showError = \_ msg -> hPutStrLn stderr msg+ }
+ library/Web/RBB/Templates/Default.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE OverloadedStrings #-}+{- |+Module : Web.RBB.Templates.Default+Description : The default blog template+Copyright : (c) Sebastian Witte+License : BSD3++Maintainer : woozletoff@gmail.com+Stability : experimental++-}+module Web.RBB.Templates.Default+ where++import qualified Data.IxSet as IxSet+import qualified Data.Set as Set+import qualified Data.Text as Text+import Data.Time+import System.Locale+import Text.Blaze.Html5 as H+import Text.Blaze.Html5.Attributes as A+import qualified Web.RBB.Config as Config+import Web.RBB.Types.Entry as E+import Web.RBB.Util++entryRenderer :: Monad m => Config.BlogConfig m -> [(Entry, Html)] -> m Html+entryRenderer cfg filteredEntries = case filteredEntries of+ [] -> return $ return ()+ [(d, m)] ->+ let metaTable = renderMetaTable (Config.timeFormatter cfg) d+ in return $ withBlogHeader [metaTable, m]+ es -> do+ bURL <- Config.baseURL cfg+ return . forM_ es $ \(d,m) -> do+ let metaBox = renderMetaBox (Config.timeFormatter cfg) bURL d+ withBlogHeader [metaBox, m]++cssFileName :: Text+cssFileName = "default.css"++timeFormatter :: UTCTime -> Text+timeFormatter = pack . formatTime defaultTimeLocale (iso8601DateFormat Nothing)++renderMetaTable :: (UTCTime -> Text) -> Entry -> Html+renderMetaTable tf = renderMetaDataForEntry+ where+ renderMetaDataForEntry ed = H.div ! class_ "meta-table" $+ table $ tbody $ mapM_ trow+ [ ("Title:", ed^.E.title)+ , ("Author:", ed^.author)+ , ("Tags:", (Text.unwords . Set.toList) (ed^.tags))+ , ("Last Update:", (tf . entryUpdateTime) (ed^.lastUpdate))+ ]+ trow :: (Text, Text) -> Html+ trow (l,r) = tr $ td (toHtml l) >> td (toHtml r)++renderMetaBox :: (UTCTime -> Text) -> Text -> Entry -> Html+renderMetaBox tf baseURL ed =+ let url = Text.concat [baseURL, "?id=", (pack . show) (ed^.entryId)]+ in H.a ! class_ "meta" ! href (toValue url) $ do+ H.span $ (toHtml . tf . entryUpdateTime . Set.findMax . IxSet.toSet) (ed^.updates)+ br+ H.span $ toHtml $ "by " <> ed^.author+++-- | Wrap the given 'Html' fragments inside a:+-- @<div class="blog-with-metadata"><section class="blog"> Html fragments </section></div>@+withBlogHeader :: [Html] -> Html+withBlogHeader es =+ H.div ! class_ "blog-with-metadata" $+ section ! class_ "blog" $ sequence_ es++-- | Given the path to the blog entries, create a 'BlogConfig' value that can+-- be used as an overrideable template with most fields using default values.+createDefaultBlogConfig :: (Monad m) => FilePath -> Config.BlogConfig m+createDefaultBlogConfig ep = Config.BlogConfig+ { Config.baseURL = return "http://127.0.0.1/blog"+ , Config.entryRenderer = entryRenderer+ , Config.timeFormatter = timeFormatter+ , Config.entryPath = ep+ , Config.updateInterval = 10+ }+
+ library/Web/RBB/Types.hs view
@@ -0,0 +1,17 @@+{- |+Module : Web.RBB.Types+Description : Data Type definitions for the blog+Copyright : (c) Sebastian Witte+License : BSD3++Maintainer : woozletoff@gmail.com+Stability : experimental++-}+module Web.RBB.Types+ ( module ReExport+ ) where++import Web.RBB.Types.Entry as ReExport+import Web.RBB.Types.FileType as ReExport+
+ library/Web/RBB/Types/Blog.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE TemplateHaskell #-}+{- |+Module : Web.RBB.Types.Blog+Description : Internal Blog state+Copyright : (c) Sebastian Witte+License : BSD3++Maintainer : woozletoff@gmail.com+Stability : experimental++-}+module Web.RBB.Types.Blog+ where++import Control.Concurrent.STM (TChan)+import Control.Lens+import Data.FileStore (FileStore)+import Data.IxSet (IxSet)+import Data.Map (Map)+import Data.Time (UTCTime)+import Web.RBB.Config+import Web.RBB.Types.CachedEntry+import Web.RBB.Types.Entry++data Blog m = Blog+ { _nextEntryId :: Integer+ , _entries :: IxSet Entry+ , _lastEntryUpdate :: EntryUpdate+ , _lastUpdateCheck :: UTCTime+ , _fileStore :: FileStore+ , _blogEntryCache :: Map Integer CachedEntry+ , _blogCacheChannel :: TChan (Integer, CachedEntry)+ , _repositoryPath :: FilePath+ , _contentRelativePath :: FilePath+ , _blogConfig :: BlogConfig m+ }+makeLenses ''Blog+
+ library/Web/RBB/Types/CachedEntry.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE TemplateHaskell #-}+{- |+Module : Web.RBB.Types.CachedEntry+Description : Type for cached entries together with some utility functions+Copyright : (c) Sebastian Witte+License : BSD3++Maintainer : woozletoff@gmail.com+Stability : experimental++-}+module Web.RBB.Types.CachedEntry+ where++import Web.RBB.Types+import Web.RBB.Util++data CachedEntry = CachedEntry+ { _entry :: Html+ , _cacheLastUpdate :: EntryUpdate+ , _cacheEntryData :: Entry+ }+makeLenses ''CachedEntry
+ library/Web/RBB/Types/Entry.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{- |+Module : Web.RBB.Types.Entry+Description : Entry data type definitions+Copyright : (c) Sebastian Witte+License : BSD3++Maintainer : woozletoff@gmail.com+Stability : experimental++This module contains a lot of newtype wrappers and is hence quite verbose. The+general contract for the unwrapping function is "get" followed by the data type+name. These instances are necessary because everything is put into an 'IxSet'+data structure.+-}+module Web.RBB.Types.Entry+ where++import Control.Lens hiding (Context, Indexable)+import Data.Data (Data, Typeable)+import Data.FileStore (RevisionId, UTCTime)+import Data.Function (on)+import Data.IxSet+import Data.Set (Set)+import Data.Text (Text)+import Web.RBB.Types.FileType++-- | Newtype around a 'UTCTime'+newtype EntryUpdateTime = EntryUpdateTime { getEntryTime :: UTCTime }+ deriving (Eq, Ord, Show, Read, Data, Typeable)+-- | Newtype around a 'RevisionId'+newtype EntryRevisionId = EntryRevisionId { getEntryRevisionId :: RevisionId }+ deriving (Eq, Ord, Show, Read, Data, Typeable)++-- | Data type storing indexing information for changes made to an 'Entry'.+data EntryUpdate = EntryUpdate+ { entryUpdateTime :: UTCTime+ , entryRevisionId :: RevisionId+ }+ deriving (Eq, Show, Read, Data, Typeable)++instance Ord EntryUpdate where+ compare a b = case (compare `on` entryUpdateTime) a b of+ EQ -> (compare `on` entryRevisionId) a b -- quite arbitrary+ c -> c++instance Indexable EntryUpdate where+ empty = ixSet+ [ ixFun $ \eu -> [ EntryUpdateTime $ entryUpdateTime eu ]+ , ixFun $ \eu -> [ EntryRevisionId $ entryRevisionId eu ]+ ]++-- | Newtype for 'Text'+newtype Title = Title { getTitle :: Text }+ deriving (Eq, Ord, Show, Read, Data, Typeable)+-- | Newtype for 'Text'+newtype AuthorName = AuthorName { getAuthorName :: Text }+ deriving (Eq, Ord, Show, Read, Data, Typeable)+-- | Newtype for 'Text'+newtype AuthorEmail = AuthorEmail { getAuthorEmail :: Text }+ deriving (Eq, Ord, Show, Read, Data, Typeable)+-- | Newtype for 'Set' 'Text'+newtype Tags = Tags { getTags :: Set Text }+ deriving (Eq, Ord, Show, Read, Data, Typeable)++-- | Newtype for 'FilePath'+newtype RelativePath = RelativePath { getRelativePath :: FilePath }+ deriving (Eq, Ord, Show, Read, Data, Typeable)+-- | Newtype for 'FilePath'+newtype FullPath = FullPath { getFullPath :: FilePath }+ deriving (Eq, Ord, Show, Read, Data, Typeable)+-- | Newtype for 'Integer'+newtype Index = Index { getIndex :: Integer }+ deriving (Eq, Ord, Show, Read, Data, Typeable)+-- | Newtype for 'EntryUpdate'+newtype LastUpdate = LastUpdate { getLastUpdate :: EntryUpdate }+ deriving (Eq, Ord, Show, Read, Data, Typeable)++-- | Metadata for a blog entry.+data Entry = Entry+ { _entryId :: Integer+ -- ^ Unique blog entry id+ , _title :: Text+ -- ^ Title of a blog entry (may change over time)+ , _author :: Text+ -- ^ Author of the blog entry+ , _authorEmail :: Text+ -- ^ Email of the author+ , _tags :: Set Text+ -- ^ Tags associated with the entry+ , _fileType :: FileType+ -- ^ File type of the actual file (determined by extension)+ , _relativePath :: FilePath+ -- ^ Path of the actual content file relative to the blog entry repository+ -- definition+ , _fullPath :: FilePath+ -- ^ Full path of the content file+ , _updates :: IxSet EntryUpdate+ -- ^ Indexable set of update times to the entry+ , _lastUpdate :: EntryUpdate+ -- ^ The latest update to the entry+ }+ deriving (Eq, Ord, Show, Read, Data, Typeable)+makeLenses ''Entry++instance Indexable Entry where+ empty = ixSet+ [ ixFun $ \e -> [ Index $ e^.entryId ]+ , ixFun $ \e -> [ Title $ e^.title ]+ , ixFun $ \e -> [ AuthorName $ e^.author ]+ , ixFun $ \e -> [ AuthorEmail $ e^.authorEmail ]+ , ixFun $ \e -> [ e^.fileType ]+ , ixFun $ \e -> [ RelativePath $ e^.relativePath ]+ , ixFun $ \e -> [ FullPath $ e^.fullPath ]+ , ixFun $ \e -> toDescList (Proxy :: Proxy EntryUpdate) (e^.updates)+ , ixFun $ \e -> [ LastUpdate $ e^.lastUpdate ]+ ]++
+ library/Web/RBB/Types/FileType.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE DeriveDataTypeable #-}+{- |+Module : Web.RBB.Types.FileType+Description : Supported file types and conversion functions+Copyright : (c) Sebastian Witte+License : BSD3++Maintainer : woozletoff@gmail.com+Stability : experimental++-}+module Web.RBB.Types.FileType+ where++import Data.Data (Data, Typeable)+import Data.Map (Map)+import qualified Data.Map as Map+import System.FilePath (takeExtensions)++-- | Enumeration that contains all supported file type extensions for blog+-- entries.+data FileType = PandocMarkdown | LiterateHaskell+ deriving (Eq, Ord, Show, Read, Enum, Data, Typeable, Bounded)++-- | This map stores all supported file type extensions mapped to the+-- appropriate 'FileType' value.+fileTypeMap :: Map FilePath FileType+fileTypeMap = Map.fromList+ [ (".md", PandocMarkdown)+ , (".lhs", LiterateHaskell)+ ]++-- | Convert the given files extension to the internal 'FileType'+-- representation.+fileTypeFromExtension :: FilePath -> Maybe FileType+fileTypeFromExtension ext = Map.lookup (takeExtensions ext) fileTypeMap+
+ library/Web/RBB/Util.hs view
@@ -0,0 +1,38 @@+{- |+Module : Web.RBB.Util+Description : Globally used utility functions+Copyright : (c) Sebastian Witte+License : BSD3++Maintainer : woozletoff@gmail.com+Stability : experimental++-}+module Web.RBB.Util+ ( module ReExport+ , ixSetModifyIx+ ) where++import Control.Applicative as ReExport+import Control.Lens as ReExport+import Control.Monad as ReExport+import Control.Monad.Base as ReExport (MonadBase)+import Data.Data as ReExport (Typeable)+import Data.Function as ReExport (on)+import Data.IxSet+import Data.IxSet as ReExport (IxSet)+import qualified Data.IxSet as IxSet+import Data.Maybe as ReExport+import Data.Monoid as ReExport+import Data.Text as ReExport (Text, pack)+import Data.Time as ReExport (UTCTime)+import Text.Blaze.Html5 as ReExport (Html)++-- | Modify the unique value indexable by @k@. If there ir no value or if there+-- are multiple values for the given index, the 'IxSet' is unmodified.+ixSetModifyIx :: (Ord a, Typeable a, IxSet.Indexable a, Typeable k)+ => k -> (a -> a) -> IxSet a -> IxSet a+ixSetModifyIx k f is = case getOne $ is @= k of+ Nothing -> is+ Just a -> insert (f a) $ delete a is+
+ repo-based-blog.cabal view
@@ -0,0 +1,119 @@+name: repo-based-blog+version: 0.0.1+synopsis: Blogging module using blaze html for markup+description:+ This package contains a module that can be used in web applications. It's use+ cases are only limited by the use of blaze for the markup of pages. If anynoe+ cares to abstract that away, I would not stand in the way.+ .+ This package also contains an executable that uses the dyre library to allow+ a configuration of a web application in the way xmonad or yi does. An examle+ can be fount in the 'RBB' module.+ .+ The blog contents are managed via a version control system. The filestore+ library has been used as a backend for this and hence the supported+ repository types mainly depend on the filestore version used. Thes currently+ suppored repository types are git, mercurial and darcs. The entries are+ rendered using the pandoc library.+ .+ For more information see the haddock documentation of the exported modules or+ the README.md included in this package.++license: BSD3+license-file: LICENSE+author: Sebastian Witte+maintainer: woozletoff@gmail.com+copyright: Copyright (C) 2014 Sebastian Witte+category: Web+homepage: https://github.com/saep/repo-based-blog+bug-reports: https://github.com/saep/repo-based-blog/issues+build-type: Simple+extra-source-files: README.md changelog.md+cabal-version: >=1.10++executable rbb+ main-is: Main.hs+ hs-source-dirs: executable+ build-depends: base >=4.6 && <5,+ repo-based-blog++ hs-source-dirs: executable+ default-language: Haskell2010+ ghc-options: -threaded -rtsopts -with-rtsopts=-N++library+ hs-source-dirs: library+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++ build-depends: base >=4.6 && <5,+ blaze-html >=0.7.0.2,+ containers,+ data-default,+ directory,+ dyre,+ filepath,+ filestore >=0.6.0.3,+ ixset,+ mtl,+ lens,+ old-locale,+ pandoc >=1.12.3.3,+ parsec >=3,+ stm,+ text,+ time,+ transformers,+ transformers-base,+ transformers-compat++ exposed-modules: Web.RBB,+ Web.RBB.Blog.Query++ other-modules: Web.RBB.Blog,+ Web.RBB.Config,+ Web.RBB.Converter,+ Web.RBB.Crawler,+ Web.RBB.Crawler.MetaCombiner,+ Web.RBB.Crawler.MetaParser,+ Web.RBB.Crawler.Repository,+ Web.RBB.Main,+ Web.RBB.Templates.Default,+ Web.RBB.Types,+ Web.RBB.Types.Blog,+ Web.RBB.Types.CachedEntry,+ Web.RBB.Types.Entry,+ Web.RBB.Types.FileType,+ Web.RBB.Util++test-suite hspec+ type: exitcode-stdio-1.0+ hs-source-dirs: test-suite, library+ main-is: Spec.hs+ default-language: Haskell2010+ build-depends: base,+ repo-based-blog,++ hspec ==2.*,+ hspec-discover,+ QuickCheck >=2.6,++ blaze-html,+ containers,+ filepath,+ directory,+ filestore,+ ixset,+ lens,+ mtl,+ old-locale,+ parsec >=3,+ stm,+ text,+ time,+ transformers,+ transformers-base,+ transformers-compat++ cpp-options: -DHTEST+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
+ test-suite/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}