This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap-static-pages".
The branch, master has been updated
via f4b3e3e8404d7a65c4338e7175dc459a38d6a2ed (commit)
from 6169a2a73292407afa511c8112dbb632c7fcc6af (commit)
Summary of changes:
snap-static-pages.cabal | 8 ++-
src/Snap/StaticPages.hs | 84 +++++++++++++++++++++++--
src/Snap/StaticPages/Internal/Handlers.hs | 5 +-
src/Snap/StaticPages/Internal/Post.hs | 97 +++++++++++++++++++++++------
4 files changed, 164 insertions(+), 30 deletions(-)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit f4b3e3e8404d7a65c4338e7175dc459a38d6a2ed
Author: Gregory Collins <[email protected]>
Date: Mon Jun 13 11:19:27 2011 -0400
Rip out annoying ConfigFile dependency
diff --git a/snap-static-pages.cabal b/snap-static-pages.cabal
index edc90e9..ac83203 100644
--- a/snap-static-pages.cabal
+++ b/snap-static-pages.cabal
@@ -21,11 +21,13 @@ Library
, Snap.StaticPages.Internal.Handlers
- ghc-options: -Wall -funbox-strict-fields -O2 -fvia-C -optc-O3
-funfolding-use-threshold=16
+ ghc-options: -Wall -funbox-strict-fields -O2 -funfolding-use-threshold=16
Build-Depends: base >= 4 && <5,
+ aeson == 0.3.*,
+ attoparsec >= 0.8.1 && <0.10,
+ attoparsec-text >= 0.8.5 && <0.9,
blaze-builder,
bytestring,
- ConfigFile,
containers,
directory,
feed,
@@ -35,7 +37,7 @@ Library
old-locale,
snap-core >= 0.4 && <0.5,
split,
- text,
+ text >= 0.11 && <0.12,
time,
transformers,
unix,
diff --git a/src/Snap/StaticPages.hs b/src/Snap/StaticPages.hs
index a09b5f8..86ca4a4 100644
--- a/src/Snap/StaticPages.hs
+++ b/src/Snap/StaticPages.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
{-|
FIXME: document this.
@@ -16,7 +18,7 @@ module Snap.StaticPages
, StaticPagesException
, staticPagesExceptionMsg
, StaticPagesState
- , staticPagesTemplateDir
+ , staticPagesTemplateDir
)
where
@@ -25,8 +27,11 @@ import Control.Concurrent.MVar
import Control.Exception
import Control.Monad
import qualified Data.ByteString.Char8 as B
-import qualified Data.ConfigFile as Cfg
+import Data.Aeson
+import qualified Data.Attoparsec as Atto
import Data.List
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
import Snap.Types
import System.Directory
import System.FilePath
@@ -81,7 +86,8 @@ initStaticPages' ts pth = do
-- make sure directories exist
mapM_ failIfNotDir [pth, contentDir, staticPagesTemplateDir pth]
- (feed, siteURL, baseURL, excludeList) <- readConfig configFilePath
+ (StaticPagesConfig feed siteURL baseURL excludeList) <-
+ readConfig configFilePath
cmap <- buildContentMap baseURL contentDir
@@ -127,10 +133,77 @@ initStaticPages' ts pth = do
staticPagesTemplateDir :: FilePath -> FilePath
staticPagesTemplateDir pth = pth </> "templates"
-getM :: Cfg.Get_C a => Cfg.ConfigParser -> String -> String -> Maybe a
-getM cp section = either (const Nothing) Just . Cfg.get cp section
+data StaticPagesConfig = StaticPagesConfig {
+ _feed :: Atom.Feed
+ , _siteURL :: String
+ , _baseURL :: String
+ , _excludes :: ExcludeList
+ }
+
+
+instance FromJSON StaticPagesConfig where
+ parseJSON (Object m) = do
+ tFeedTitle <- m .: "feedTitle"
+ tAuthors <- m .: "feedAuthors"
+ tBaseURL <- m .: "baseURL"
+ tSiteURL <- m .: "siteURL"
+ tIcon <- m .:? "icon"
+ tSkipStr <- m .:? "skipurls"
+
+ let skip = maybe EL.empty
+ (EL.fromPathList . T.encodeUtf8)
+ tSkipStr
+
+ let feedTitle = T.unpack tFeedTitle
+ let authors = T.unpack tAuthors
+ let baseURL = stripSuffix '/' $ ensurePrefix '/' $ T.unpack tBaseURL
+ let siteURL = stripSuffix '/' $ T.unpack tSiteURL
+ let feedURL = siteURL ++ baseURL
+ let icon = fmap T.unpack tIcon
+
+ let feed = Atom.nullFeed feedURL
+ (Atom.TextString feedTitle)
+ ""
+
+ let feed' = feed { Atom.feedAuthors = parsePersons authors
+ , Atom.feedIcon = icon
+ , Atom.feedLinks = [ Atom.nullLink feedURL ]
+ }
+
+ return $! StaticPagesConfig feed' siteURL baseURL skip
+
+
+ where
+ ensurePrefix :: Char -> String -> String
+ ensurePrefix p s = if [p] `isPrefixOf` s then s else p:s
+
+ stripSuffix :: Char -> String -> String
+ stripSuffix x s = if [x] `isSuffixOf` s then init s else s
+
+
+ parseJSON _ = mzero
+
+
+readConfig :: FilePath -> IO StaticPagesConfig
+readConfig fp = do
+ contents <- B.readFile fp
+ let val = either errorOut id $ Atto.parseOnly json contents
+ return $! resToVal $! fromJSON val
+
+ where
+ errorOut e = error $ concat [
+ "Error parsing config file \""
+ , fp
+ , "\": "
+ , e ]
+
+ resToVal (Error e) = error e
+ resToVal (Success x) = x
+
+
+{-
readConfig :: FilePath -> IO (Atom.Feed, String, String, ExcludeList)
readConfig fp = do
cp <- parseConfig fp
@@ -178,3 +251,4 @@ readConfig fp = do
parseConfig :: FilePath -> IO (Either Cfg.CPError Cfg.ConfigParser)
parseConfig = Cfg.readfile Cfg.emptyCP
+-}
diff --git a/src/Snap/StaticPages/Internal/Handlers.hs
b/src/Snap/StaticPages/Internal/Handlers.hs
index 9f16320..d7201b7 100644
--- a/src/Snap/StaticPages/Internal/Handlers.hs
+++ b/src/Snap/StaticPages/Internal/Handlers.hs
@@ -10,7 +10,6 @@ import Control.Monad.Reader
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.UTF8 as UTF8
import Data.List
import qualified Data.Map as Map
import Data.Maybe
@@ -18,7 +17,7 @@ import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Snap.Types
-import Snap.Util.FileServe
+import qualified Snap.Util.FileServe as FS
import qualified Text.Atom.Feed as Atom
import qualified Text.Atom.Feed.Export as Atom
import Text.Templating.Heist
@@ -66,7 +65,7 @@ serveStaticPages' state = method GET $ do
else
maybe mzero
(\f -> case f of
- (ContentStatic fp) -> lift $ fileServeSingle fp
+ (ContentStatic fp) -> lift $ FS.serveFile fp
(ContentPost post) -> servePost (soFar ++ [a])
post
(ContentDirectory _ d) -> serveIndex (soFar ++ [a])
d)
(Map.lookup a content)
diff --git a/src/Snap/StaticPages/Internal/Post.hs
b/src/Snap/StaticPages/Internal/Post.hs
index 2f3ce16..01f1447 100644
--- a/src/Snap/StaticPages/Internal/Post.hs
+++ b/src/Snap/StaticPages/Internal/Post.hs
@@ -35,16 +35,20 @@ where
------------------------------------------------------------------------
import Control.Applicative
import Control.Exception
-import "mtl" Control.Monad.Error
-import "mtl" Control.Monad.Identity
+import Control.Monad.Error
+import qualified Data.Attoparsec.Text as Atto
+import Data.Attoparsec.Text (Parser)
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.UTF8 as UTF8
import Data.Char
-import qualified Data.ConfigFile as Cfg
import Data.List
import Data.List.Split
import qualified Data.Map as Map
+import Data.Map (Map)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Time.LocalTime
@@ -52,7 +56,6 @@ import System.Directory
import System.FilePath
import System.Posix.Files
import Text.Atom.Feed
-import Text.Printf
import Text.XML.Light
import Text.Templating.Heist.Splices.Markdown
@@ -90,11 +93,17 @@ parsePersons = map mkPerson . endBy ","
(c,_) = span (/= '>') b
+emptyPost :: String -> Date -> Post
+emptyPost pId atm = Post $ nullEntry pId (HTMLString "") atm
+
+
+{-
+
+FIXME: REMOVE
parseHeaders :: String -> (Either Cfg.CPError Cfg.ConfigParser)
parseHeaders = Cfg.readstring Cfg.emptyCP
-
getKVP :: Cfg.ConfigParser -> String -> Maybe String
getKVP cp key = retval
where
@@ -102,6 +111,55 @@ getKVP cp key = retval
e = runIdentity . runErrorT $ Cfg.get cp "DEFAULT" key
retval = case e of Left _ -> Nothing
Right x -> Just x
+-}
+
+
+headerParser :: Parser [(Text,Text)]
+headerParser = go id
+ where
+ endOfLine c = c == '\r' || c == '\n'
+
+ parseLine = do
+ !l <- Atto.takeWhile (not . endOfLine)
+ _ <- Atto.takeWhile endOfLine
+ return l
+
+ goLine = do
+ k <- Atto.takeWhile (\c -> c /= ':' && not (endOfLine c))
+ _ <- Atto.takeWhile1 (== ':')
+ v <- Atto.takeWhile (not . endOfLine)
+ _ <- Atto.takeWhile endOfLine
+
+ continue (T.strip k) (T.strip v)
+
+ continue !k !v = (Atto.try $ do
+ _ <- Atto.takeWhile1 isSpace
+ l <- parseLine
+ continue k (T.concat [ v, " ", T.strip l ]))
+ <|> return (k,v)
+
+ go !dlist = do
+ end <- Atto.atEnd
+ if end
+ then return $! dlist []
+ else do
+ (k,v) <- goLine
+ go (dlist . ((T.toLower k, v):))
+
+
+stringToHeaders :: ByteString -> IO (Map Text Text)
+stringToHeaders bsHdrs = do
+ liftM (Map.fromList) $
+ either (throwIO . StaticPagesException . formatMsg)
+ return
+ (Atto.parseOnly headerParser txtHdrs)
+ where
+ formatMsg s = concat [ "Error parsing headers: "
+ , s
+ , "\nHeaders were:\n"
+ , T.unpack txtHdrs ]
+ txtHdrs = T.decodeUtf8 bsHdrs
+
headerTable :: [(String, String -> Post -> Post)]
@@ -129,6 +187,20 @@ breakPost s = (B.unlines hdr, B.unlines body)
hdr = chomp `map` hdr'
+parseHeaders :: ByteString -- ^ headers
+ -> [(String, String -> Post -> Post)] -- ^ header table
+ -> Post
+ -> IO Post
+parseHeaders str table post = do
+ kvps <- stringToHeaders str
+
+ return $ foldl (\p (k,f) -> case Map.lookup (T.pack k) kvps of
+ Nothing -> p
+ Just x -> f (T.unpack x) p)
+ post
+ table
+
+
readPost :: String -> FilePath -> IO Post
readPost pId path = do
!tz <- getCurrentTimeZone
@@ -139,20 +211,7 @@ readPost pId path = do
let (hdr,body) = breakPost contents
- let !hdrS = B.unpack hdr
-
- let !cfg = case parseHeaders hdrS of
- Left e -> error
- $ printf "Couldn't parse headers from %s:\n%s"
- path (show e)
- Right r -> r
-
- let !post = foldl (\p (k,f) ->
- case getKVP cfg k of
- Nothing -> p
- Just x -> f x p)
- (Post $ nullEntry pId (HTMLString "") atm)
- headerTable
+ !post <- parseHeaders hdr headerTable $ emptyPost pId atm
mbPandocpath <- findExecutable "pandoc"
-----------------------------------------------------------------------
hooks/post-receive
--
snap-static-pages
_______________________________________________
Snap mailing list
[email protected]
https://mailman-mail5.webfaction.com/listinfo/snap
