snaplet-wordpress (empty) → 0.1.1.0
raw patch · 17 files changed
+1387/−0 lines, 17 filesdep +aesondep +asyncdep +attoparsecsetup-changed
Dependencies added: aeson, async, attoparsec, base, blaze-builder, bytestring, configurator, containers, data-default, either, hedis, heist, hspec, hspec-snap, lens, map-syntax, mtl, network, snap, snap-core, snaplet-redis, snaplet-wordpress, text, time, unordered-containers, vector, wreq, xmlhtml
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- snaplet-wordpress.cabal +85/−0
- spec/Main.hs +368/−0
- src/Snap/Snaplet/Wordpress.hs +36/−0
- src/Snap/Snaplet/Wordpress/Cache.hs +98/−0
- src/Snap/Snaplet/Wordpress/Cache/Redis.hs +36/−0
- src/Snap/Snaplet/Wordpress/Cache/Types.hs +10/−0
- src/Snap/Snaplet/Wordpress/Field.hs +79/−0
- src/Snap/Snaplet/Wordpress/HTTP.hs +29/−0
- src/Snap/Snaplet/Wordpress/Init.hs +67/−0
- src/Snap/Snaplet/Wordpress/Internal.hs +48/−0
- src/Snap/Snaplet/Wordpress/Posts.hs +33/−0
- src/Snap/Snaplet/Wordpress/Queries.hs +28/−0
- src/Snap/Snaplet/Wordpress/Splices.hs +216/−0
- src/Snap/Snaplet/Wordpress/Types.hs +149/−0
- src/Snap/Snaplet/Wordpress/Utils.hs +73/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Daniel Patterson++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 Daniel Patterson 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
+ snaplet-wordpress.cabal view
@@ -0,0 +1,85 @@+name: snaplet-wordpress+version: 0.1.1.0+synopsis: A snaplet that communicates with wordpress over it's api.+-- description:+homepage: https://github.com/dbp/snaplet-wordpress+license: BSD3+license-file: LICENSE+author: Daniel Patterson+maintainer: dbp@dbpmail.net+-- copyright:+category: Web+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ exposed-modules:+ Snap.Snaplet.Wordpress+ other-modules: Snap.Snaplet.Wordpress.Internal+ , Snap.Snaplet.Wordpress.Types+ , Snap.Snaplet.Wordpress.Field+ , Snap.Snaplet.Wordpress.Init+ , Snap.Snaplet.Wordpress.Splices+ , Snap.Snaplet.Wordpress.Queries+ , Snap.Snaplet.Wordpress.HTTP+ , Snap.Snaplet.Wordpress.Cache+ , Snap.Snaplet.Wordpress.Cache.Types+ , Snap.Snaplet.Wordpress.Cache.Redis+ , Snap.Snaplet.Wordpress.Posts+ , Snap.Snaplet.Wordpress.Utils+ -- other-extensions:+ build-depends: aeson+ , base >=4.5 && <4.8+ , blaze-builder >= 0.3.3.3+ , data-default+ , hedis+ , heist >= 0.14+ , map-syntax+ , lens < 4.4+ , snap >= 0.13 && < 0.14+ , snap-core >= 0.9 && < 0.10+ , snaplet-redis+ , text+ , bytestring+ , wreq < 0.2+ , configurator+ , time >= 1.4 && < 1.6+ , xmlhtml >= 0.2.3.2+ -- NOTE(dbp 2014-09-10): network is a transitive dependency,+ -- because cabal couldn't figure it out.+ , network < 2.6+ , async+ , hspec >= 2+ , hspec-snap+ , mtl+ , either+ , unordered-containers+ , containers+ , vector+ , attoparsec+ hs-source-dirs: src+ default-language: Haskell2010++Test-Suite test-snaplet-wordpress+ type: exitcode-stdio-1.0+ hs-source-dirs: spec+ main-is: Main.hs+ build-depends: base >= 4.6 && < 4.8+ , heist+ , hspec-snap+ , hspec >= 2+ , snap+ , snaplet-wordpress+ , blaze-builder+ , snaplet-redis+ , lens+ , data-default+ , text+ , xmlhtml+ , mtl+ , either+ , unordered-containers+ , aeson+ , containers+ , hedis
+ spec/Main.hs view
@@ -0,0 +1,368 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module Main where++import Prelude hiding ((++))++import Blaze.ByteString.Builder+import Control.Concurrent.MVar+import Control.Lens hiding ((.=))+import Data.Aeson hiding (Success)+import Data.Default+import qualified Data.HashMap.Strict as M+import Data.Maybe+import Data.Monoid+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL+import Heist+import Heist.Compiled+import qualified Misc+import Snap hiding (get)+import Snap.Snaplet.Heist.Compiled+import Snap.Snaplet.RedisDB+import Test.Hspec+import Test.Hspec.Core.Spec (Result (..))+import Test.Hspec.Snap+import qualified Text.XmlHtml as X++import Snap.Snaplet.Wordpress+import Snap.Snaplet.Wordpress.Cache.Redis+import Snap.Snaplet.Wordpress.Types++(++) :: Monoid a => a -> a -> a+(++) = mappend++----------------------------------------------------------+-- Section 1: Example application used for testing. --+----------------------------------------------------------++data App = App { _heist :: Snaplet (Heist App)+ , _redis :: Snaplet RedisDB+ , _wordpress :: Snaplet (Wordpress App) }++makeLenses ''App++instance HasHeist App where+ heistLens = subSnaplet heist++enc a = TL.toStrict . TL.decodeUtf8 . encode $ a++article2 = object [ "ID" .= (2 :: Int)+ , "title" .= ("The post" :: Text)+ , "excerpt" .= ("summary" :: Text)+ ]++jacobinFields = [N "featured_image" [N "attachment_meta" [N "sizes" [N "mag-featured" [F "width"+ ,F "height"+ ,F "url"]+ ,N "single-featured" [F "width"+ ,F "height"+ ,F "url"]]]]]++renderingApp :: [(Text, Text)] -> Text -> SnapletInit App App+renderingApp tmpls response = makeSnaplet "app" "App." Nothing $ do+ h <- nestSnaplet "" heist $ heistInit ""+ addConfig h $ set scTemplateLocations (return templates) mempty+ r <- nestSnaplet "" redis redisDBInitConf+ w <- nestSnaplet "" wordpress $ initWordpress' config h r wordpress+ return $ App h r w+ where mkTmpl (name, html) = let (Right doc) = X.parseHTML "" (T.encodeUtf8 html)+ in ([T.encodeUtf8 name], DocumentFile doc Nothing)+ templates = return $ M.fromList (map mkTmpl tmpls)+ config = (def { wpConfEndpoint = ""+ , wpConfRequester = Just $ Requester (\_ _ -> return response)+ , wpConfCacheBehavior = NoCache+ , wpConfExtraFields = jacobinFields})++queryingApp :: [(Text, Text)] -> MVar [Text] -> SnapletInit App App+queryingApp tmpls record = makeSnaplet "app" "An snaplet example application." Nothing $ do+ h <- nestSnaplet "" heist $ heistInit "templates"+ addConfig h $ set scTemplateLocations (return templates) mempty+ r <- nestSnaplet "" redis redisDBInitConf+ w <- nestSnaplet "" wordpress $ initWordpress' config h r wordpress+ return $ App h r w+ where mkTmpl (name, html) = let (Right doc) = X.parseHTML "" (T.encodeUtf8 html)+ in ([T.encodeUtf8 name], DocumentFile doc Nothing)+ templates = return $ M.fromList (map mkTmpl tmpls)+ config = (def { wpConfEndpoint = ""+ , wpConfRequester = Just $ Requester recordingRequester+ , wpConfCacheBehavior = NoCache})+ recordingRequester "/taxonomies/post_tag/terms" [] =+ return $ enc $ [object [ "ID" .= (177 :: Int)+ , "slug" .= ("home-featured" :: Text)+ , "meta" .= object ["links" .= object ["self" .= ("/177" :: Text)]]+ ]+ ,object [ "ID" .= (160 :: Int)+ , "slug" .= ("featured-global" :: Text)+ , "meta" .= object ["links" .= object ["self" .= ("/160" :: Text)]]+ ]+ ]+ recordingRequester "/taxonomies/category/terms" [] =+ return $ enc $ [object [ "ID" .= (159 :: Int)+ , "slug" .= ("bookmarx" :: Text)+ , "meta" .= object ["links" .= object ["self" .= ("/159" :: Text)]]+ ]+ ]+ recordingRequester url params = do+ modifyMVar_ record $ (return . (++ [mkUrlUnescape url params]))+ return ""+ mkUrlUnescape url params = (url <> "?" <> (T.intercalate "&" $ map (\(k, v) -> k <> "=" <> v) params))++cachingApp :: SnapletInit App App+cachingApp = makeSnaplet "app" "An snaplet example application." Nothing $ do+ h <- nestSnaplet "" heist $ heistInit "templates"+ r <- nestSnaplet "" redis redisDBInitConf+ w <- nestSnaplet "" wordpress $ initWordpress' config h r wordpress+ return $ App h r w+ where config = (def { wpConfEndpoint = ""+ , wpConfRequester = Just $ Requester (\_ _ -> return "")+ , wpConfCacheBehavior = CacheSeconds 10})++----------------------------------------------------------+-- Section 2: Test suite against application. --+----------------------------------------------------------++shouldRenderTo :: (Text, Text) -> Text -> Spec+shouldRenderTo (tags, response) match =+ snap (route []) (renderingApp [("test", tags)] response) $+ it (T.unpack $ tags ++ " should render to match " ++ match) $+ do t <- eval (do st <- getHeistState+ builder <- (fst . fromJust) $ renderTemplate st "test"+ return $ T.decodeUtf8 $ toByteString builder)+ setResult $+ if match == t+ then Success+ else Fail (show t <> " didn't match " <> show match)++clearRedisCache :: Handler App App Bool+clearRedisCache = runRedisDB redis $ rdelstar "wordpress:*"++article1 :: Value+article1 = object [ "ID" .= ("1" :: Text)+ , "title" .= ("Foo bar" :: Text)+ , "excerpt" .= ("summary" :: Text)+ ]++main :: IO ()+main = hspec $ do+ Misc.tests+ describe "<wpPosts>" $ do+ ("<wp><wpPosts><wpTitle/></wpPosts></wp>", enc [article1]) `shouldRenderTo` "Foo bar"+ ("<wp><wpPosts><wpID/></wpPosts></wp>", enc [article1]) `shouldRenderTo` "1"+ ("<wp><wpPosts><wpExcerpt/></wpPosts></wp>", enc [article1]) `shouldRenderTo` "summary"+ describe "<wpNoPostDuplicates/>" $ do+ ("<wp><wpNoPostDuplicates/><wpPosts><wpTitle/></wpPosts><wpPosts><wpTitle/></wpPosts></wp>", enc [article1])+ `shouldRenderTo` "Foo bar"+ ("<wp><wpPosts><wpTitle/></wpPosts><wpNoPostDuplicates/><wpPosts><wpTitle/></wpPosts></wp>", enc [article1])+ `shouldRenderTo` "Foo barFoo bar"+ ("<wp><wpPosts><wpTitle/></wpPosts><wpNoPostDuplicates/><wpPosts><wpTitle/></wpPosts><wpPosts><wpTitle/></wpPosts></wp>", enc [article1])+ `shouldRenderTo` "Foo barFoo bar"+ ("<wp><wpPosts><wpTitle/></wpPosts><wpPosts><wpTitle/></wpPosts><wpNoPostDuplicates/></wp>", enc [article1])+ `shouldRenderTo` "Foo barFoo bar"+{- describe "<wpPostByPermalink>" $ do+ shouldRenderAtUrl "/2009/10/the-post/"+ "<wp><wpPostByPermalink><wpTitle/></wpPostByPermalink></wp>"+ "The post"+ shouldRenderAtUrl "/posts/2009/10/the-post/"+ "<wp><wpPostByPermalink><wpTitle/></wpPostByPermalink></wp>"+ "The post"+ shouldRenderAtUrl "/posts/2009/10/the-post"+ "<wp><wpPostByPermalink><wpTitle/></wpPostByPermalink></wp>"+ "The post"+ shouldRenderAtUrl "/2009/10/the-post/"+ "<wp><wpPostByPermalink><wpTitle/>: <wpExcerpt/></wpPostByPermalink></wp>"+ "The post: summary" -}+{- describe "should grab post from cache if it's there" $+ let (Object a2) = article2 in+ shouldRenderAtUrlPreCache+ (void $ with wordpress $ cacheSet (Just 10) (PostByPermalinkKey "2001" "10" "the-post")+ (enc a2))+ "/2001/10/the-post/"+ "<wp><wpPostByPermalink><wpTitle/></wpPostByPermalink></wp>"+ "The post" -}+ describe "caching" $ snap (route []) cachingApp $ afterEval (void clearRedisCache) $ do+ it "should find nothing for a non-existent post" $ do+ p <- eval (with wordpress $ wpCacheGet' (PostByPermalinkKey "2000" "1" "the-article"))+ p `shouldEqual` Nothing+ it "should find something if there is a post in cache" $ do+ eval (with wordpress $ wpCacheSet' (PostByPermalinkKey "2000" "1" "the-article")+ (enc article1))+ p <- eval (with wordpress $ wpCacheGet' (PostByPermalinkKey "2000" "1" "the-article"))+ p `shouldEqual` (Just $ enc article1)+ it "should not find single post after expire handler is called" $+ do eval (with wordpress $ wpCacheSet' (PostByPermalinkKey "2000" "1" "the-article")+ (enc article1))+ eval (with wordpress $ wpExpirePost' (PostByPermalinkKey "2000" "1" "the-article"))+ eval (with wordpress $ wpCacheGet' (PostByPermalinkKey "2000" "1" "the-article"))+ >>= shouldEqual Nothing+ it "should find post aggregates in cache" $+ do let key = PostsKey (Set.fromList [NumFilter 20, OffsetFilter 0])+ eval (with wordpress $ wpCacheSet' key ("[" ++ enc article1 ++ "]"))+ eval (with wordpress $ wpCacheGet' key)+ >>= shouldEqual (Just $ "[" ++ enc article1 ++ "]")+ it "should not find post aggregates after expire handler is called" $+ do let key = PostsKey (Set.fromList [NumFilter 20, OffsetFilter 0])+ eval (with wordpress $ wpCacheSet' key ("[" ++ enc article1 ++ "]"))+ eval (with wordpress $ wpExpirePost' (PostByPermalinkKey "2000" "1" "the-article"))+ eval (with wordpress $ wpCacheGet' key)+ >>= shouldEqual Nothing+ it "should find single post after expiring aggregates" $+ do eval (with wordpress $ wpCacheSet' (PostByPermalinkKey "2000" "1" "the-article")+ (enc article1))+ eval (with wordpress wpExpireAggregates')+ eval (with wordpress $ wpCacheGet' (PostByPermalinkKey "2000" "1" "the-article"))+ >>= shouldNotEqual Nothing+ it "should find a different single post after expiring another" $+ do let key1 = (PostByPermalinkKey "2000" "1" "the-article")+ key2 = (PostByPermalinkKey "2001" "2" "another-article")+ eval (with wordpress $ wpCacheSet' key1 (enc article1))+ eval (with wordpress $ wpCacheSet' key2 (enc article2))+ eval (with wordpress $ wpExpirePost' (PostByPermalinkKey "2000" "1" "the-article"))+ eval (with wordpress $ wpCacheGet' key2) >>= shouldEqual (Just (enc article2))+ it "should be able to cache and retrieve post" $+ do let key = (PostKey 200)+ eval (with wordpress $ wpCacheSet' key (enc article1))+ eval (with wordpress $ wpCacheGet' key) >>= shouldEqual (Just (enc article1))++ describe "generate queries from <wpPosts>" $ do+ shouldQueryTo+ "<wpPosts></wpPosts>"+ ["/posts?filter[offset]=0&filter[posts_per_page]=20"]+ shouldQueryTo+ "<wpPosts limit=2></wpPosts>"+ ["/posts?filter[offset]=0&filter[posts_per_page]=20"]+ shouldQueryTo+ "<wpPosts offset=1 limit=1></wpPosts>"+ ["/posts?filter[offset]=1&filter[posts_per_page]=20"]+ shouldQueryTo+ "<wpPosts offset=0 limit=1></wpPosts>"+ ["/posts?filter[offset]=0&filter[posts_per_page]=20"]+ shouldQueryTo+ "<wpPosts limit=10 page=1></wpPosts>"+ ["/posts?filter[offset]=0&filter[posts_per_page]=20"]+ shouldQueryTo+ "<wpPosts limit=10 page=2></wpPosts>"+ ["/posts?filter[offset]=20&filter[posts_per_page]=20"]+ shouldQueryTo+ "<wpPosts num=2></wpPosts>"+ ["/posts?filter[offset]=0&filter[posts_per_page]=2"]+ shouldQueryTo+ "<wpPosts num=2 page=2 limit=1></wpPosts>"+ ["/posts?filter[offset]=2&filter[posts_per_page]=2"]+ shouldQueryTo+ "<wpPosts num=1 page=3></wpPosts>"+ ["/posts?filter[offset]=2&filter[posts_per_page]=1"]+ shouldQueryTo+ "<wpPosts tags=\"+home-featured\" limit=10></wpPosts>"+ ["/posts?filter[offset]=0&filter[posts_per_page]=20&filter[tag__in]=177"]+ shouldQueryTo+ "<wpPosts tags=\"-home-featured\" limit=1></wpPosts>"+ ["/posts?filter[offset]=0&filter[posts_per_page]=20&filter[tag__not_in]=177"]+ shouldQueryTo+ "<wpPosts tags=\"+home-featured,-featured-global\" limit=1><wpTitle/></wpPosts>"+ ["/posts?filter[offset]=0&filter[posts_per_page]=20&filter[tag__in]=177&filter[tag__not_in]=160"]+ shouldQueryTo+ "<wpPosts tags=\"+home-featured,+featured-global\" limit=1><wpTitle/></wpPosts>"+ ["/posts?filter[offset]=0&filter[posts_per_page]=20&filter[tag__in]=160&filter[tag__in]=177"]+ shouldQueryTo+ "<wpPosts categories=\"bookmarx\" limit=10><wpTitle/></wpPosts>"+ ["/posts?filter[category__in]=159&filter[offset]=0&filter[posts_per_page]=20"]+ shouldQueryTo+ "<wpPosts categories=\"-bookmarx\" limit=10><wpTitle/></wpPosts>"+ ["/posts?filter[category__not_in]=159&filter[offset]=0&filter[posts_per_page]=20"]+ shouldQueryTo+ "<wp><div><wpPosts categories=\"bookmarx\" limit=10><wpTitle/></wpPosts></div></wp>"+ (replicate 2 "/posts?filter[category__in]=159&filter[offset]=0&filter[posts_per_page]=20")+++shouldQueryTo :: Text -> [Text] -> Spec+shouldQueryTo hQuery wpQuery = do+ record <- runIO $ newMVar []+ snap (route []) (queryingApp [("x", hQuery)] record) $+ it ("query from " <> T.unpack hQuery) $ do+ eval $ render "x"+ x <- liftIO $ tryTakeMVar record+ x `shouldEqual` Just wpQuery++{- describe "live tests (which require config file w/ user and pass to sandbox.jacobinmag.com)" $+ snap (route [("/2014/10/a-war-for-power", render "single")+ ,("/2014/10/the-assassination-of-detroit/", render "author-date")+ ])+ (queryingApp [("single", "<wp><wpPostByPermalink><wpTitle/></wpPostByPermalink></wp>")+ ,("author-date", "<wp><wpPostByPermalink><wpAuthor><wpName/></wpAuthor><wpDate><wpYear/>/<wpMonth/></wpDate></wpPostByPermalink></wp>")+ ,("fields", "<wp><wpPosts limit=1 categories=\"-bookmarx\"><wpFeaturedImage><wpAttachmentMeta><wpSizes><wpThumbnail><wpUrl/></wpThumbnail></wpSizes></wpAttachmentMeta></wpFeaturedImage></wpPosts></wp>")+ ,("extra-fields", "<wp><wpPosts limit=1 categories=\"-bookmarx\"><wpFeaturedImage><wpAttachmentMeta><wpSizes><wpMagFeatured><wpUrl/></wpMagFeatured></wpSizes></wpAttachmentMeta></wpFeaturedImage></wpPosts></wp>")+ ]+ ) $+ do it "should have title on page" $+ get "/2014/10/a-war-for-power" >>= shouldHaveText "A War for Power"+ it "should not have most recent post's title" $+ do p1 <- get "/many"+ get "/many1" >>= shouldNotEqual p1+ it "should be able to offset" $+ do res <- get "/many2"+ res2 <- get "/many3"+ res `shouldNotEqual` res2+ it "should be able to get page 2" $+ do p1 <- get "/page1"+ get "/page2" >>= shouldNotEqual p1+ it "should be able to use page, num, and limit" $+ do p1 <- get "/num1"+ p2 <- get "/num2"+ p3 <- get "/num3"+ p1 `shouldNotEqual` p2+ p2 `shouldEqual` p3+ it "should be able to restrict based on tags" $+ do p1 <- get "/tag1"+ get "/tag2" >>= shouldNotEqual p1+ it "should be able to say +tag instead of tag" $+ do p1 <- get "/tag1"+ get "/tag3" >>= shouldEqual p1+ it "should be able to say -tag to NOT match a tag" $+ do p1 <- get "/tag4"+ get "/tag5" >>= shouldNotEqual p1+ it "should be able to have multiple tag queries" $+ do p1 <- get "/tag6"+ get "/tag7" >>= shouldNotEqual p1+ it "should be able to get nested attribute author name" $+ get "/2014/10/the-assassination-of-detroit/" >>= shouldHaveText "Carlos Salazar"+ it "should be able to get customly parsed attribute date" $+ get "/2014/10/the-assassination-of-detroit/" >>= shouldHaveText "2014/10"+ it "should be able to restrict based on category" $+ do c1 <- get "/cat1"+ c2 <- get "/cat2"+ c1 `shouldNotEqual` c2+ it "should be able to make negative category queries" $+ do c1 <- get "/cat1"+ c2 <- get "/cat3"+ c1 `shouldNotEqual` c2+ it "should be able to use extra fields set in application" $+ do get "/fields" >>= shouldHaveText "https://"+ get "/extra-fields" >>= shouldHaveText "https://"+-}++getWordpress :: Handler b v v+getWordpress = view snapletValue <$> getSnapletState++wpCacheGet' :: WPKey -> Handler b (Wordpress b) (Maybe Text)+wpCacheGet' wpKey = do+ WordpressInt{..} <- cacheInternals <$> getWordpress+ liftIO $ wpCacheGet wpKey+wpCacheSet' :: WPKey -> Text -> Handler b (Wordpress b) ()+wpCacheSet' wpKey o = do+ WordpressInt{..} <- cacheInternals <$> getWordpress+ liftIO $ wpCacheSet wpKey o++wpExpireAggregates' = do+ Wordpress{..} <- getWordpress+ liftIO $ wpExpireAggregates++wpExpirePost' k = do+ Wordpress{..} <- getWordpress+ liftIO $ wpExpirePost k
+ src/Snap/Snaplet/Wordpress.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Snap.Snaplet.Wordpress (+ Wordpress(..)+ , WordpressConfig(..)+ , Requester(..)+ , CacheBehavior(..)+ , initWordpress+ , initWordpress'+ , wpGetPost+ , getPost+ , WPKey(..)+ , Filter(..)+ , transformName+ , TaxSpec(..)+ , TagType+ , CatType+ , TaxSpecList(..)+ , Field(..)+ , mergeFields+ ) where++import Snap.Snaplet.Wordpress.Cache.Types+import Snap.Snaplet.Wordpress.Field+import Snap.Snaplet.Wordpress.HTTP+import Snap.Snaplet.Wordpress.Init+import Snap.Snaplet.Wordpress.Splices+import Snap.Snaplet.Wordpress.Types
+ src/Snap/Snaplet/Wordpress/Cache.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}++module Snap.Snaplet.Wordpress.Cache where++import Control.Concurrent.MVar+import Data.Monoid ((<>))+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Time.Clock (getCurrentTime, diffUTCTime, UTCTime)+import Database.Redis (Redis)+import Snap++import Snap.Snaplet.Wordpress.Cache.Redis+import Snap.Snaplet.Wordpress.Cache.Types+import Snap.Snaplet.Wordpress.Types+import Snap.Snaplet.Wordpress.Utils++startReqMutexInt :: MVar (Map WPKey UTCTime) -> WPKey -> IO Bool+startReqMutexInt activeMV wpKey =+ do now <- getCurrentTime+ modifyMVar activeMV $ \a ->+ let active = filterCurrent now a+ in if Map.member wpKey active+ then return (active, True)+ else return (Map.insert wpKey now active, False)+ where filterCurrent now = Map.filter (\v -> diffUTCTime now v < 1)++stopReqMutexInt :: MVar (Map WPKey UTCTime) -> WPKey -> IO ()+stopReqMutexInt activeMV wpKey =+ modifyMVar_ activeMV $ return . Map.delete wpKey++cachingGetRetryInt :: (WordpressInt b) -> WPKey -> IO Text+cachingGetRetryInt wp = retryUnless . (cachingGetInt wp)++cachingGetErrorInt :: (WordpressInt b) -> WPKey -> IO Text+cachingGetErrorInt wp wpKey = errorUnless msg (cachingGetInt wp wpKey)+ where msg = ("Could not retrieve " <> tshow wpKey)++cachingGetInt :: WordpressInt b+ -> WPKey+ -> IO (Maybe Text)+cachingGetInt WordpressInt{..} wpKey =+ do cached <- wpCacheGet wpKey+ case cached of+ Just _ -> return cached+ Nothing ->+ do running <- startReqMutex wpKey+ if running+ then return Nothing+ else+ do o <- wpRequest wpKey+ wpCacheSet wpKey o+ stopReqMutex wpKey+ return $ Just o++wpCacheGetInt :: RunRedis -> CacheBehavior -> WPKey -> IO (Maybe Text)+wpCacheGetInt runRedis b = runRedis . (cacheGet b) . formatKey++cacheGet :: CacheBehavior -> Text -> Redis (Maybe Text)+cacheGet NoCache _ = return Nothing+cacheGet _ key = rget key++wpCacheSetInt :: RunRedis -> CacheBehavior -> WPKey -> Text -> IO ()+wpCacheSetInt runRedis b key = void . runRedis . (cacheSet b (formatKey key))++cacheSet :: CacheBehavior -> Text -> Text -> Redis Bool+cacheSet b k v =+ case b of+ (CacheSeconds n) -> rsetex k n v+ CacheForever -> rset k v+ NoCache -> return True++wpExpireAggregatesInt :: RunRedis -> IO Bool+wpExpireAggregatesInt runRedis = runRedis expireAggregates++expireAggregates :: Redis Bool+expireAggregates = rdelstar "wordpress:posts:*"++wpExpirePostInt :: RunRedis -> WPKey -> IO Bool+wpExpirePostInt runRedis = runRedis . expire++expire :: WPKey -> Redis Bool+expire key = rdel [formatKey key] >> expireAggregates++formatKey :: WPKey -> Text+formatKey = format+ where format (PostByPermalinkKey y m s) = ns "post_perma:" <> y <> "_" <> m <> "_" <> s+ format (PostsKey filters) =+ ns "posts:" <> T.intercalate "_" (map tshow $ Set.toAscList filters)+ format (PostKey n) = ns "post:" <> tshow n+ format (AuthorKey n) = ns "author:" <> tshow n+ format (TaxDictKey t) = ns "tax_dict:" <> t+ ns k = "wordpress:" <> k
+ src/Snap/Snaplet/Wordpress/Cache/Redis.hs view
@@ -0,0 +1,36 @@+module Snap.Snaplet.Wordpress.Cache.Redis where++import Control.Applicative ((<$>))+import Control.Monad (join)+import Data.Either (isRight)+import Data.Text (Text)+import qualified Data.Text.Encoding as T+import Database.Redis (Redis)+import qualified Database.Redis as R++rsetex :: Text -> Int -> Text -> Redis Bool+rsetex k n v = isRight <$> R.setex (T.encodeUtf8 k) (toInteger n) (T.encodeUtf8 v)++rset :: Text -> Text -> Redis Bool+rset k v = isRight <$> R.set (T.encodeUtf8 k) (T.encodeUtf8 v)++rget :: Text -> Redis (Maybe Text)+rget k = (fmap T.decodeUtf8) <$> join <$> eitherToMaybe <$> R.get (T.encodeUtf8 k)+ where eitherToMaybe :: Either a b -> Maybe b+ eitherToMaybe e =+ case e of+ Right a -> Just a+ Left _err -> Nothing++rdel :: [Text] -> Redis Bool+rdel k = isRight <$> R.del (map T.encodeUtf8 k)++rkeys :: Text -> Redis [Text]+rkeys k =+ do e <- R.keys $ T.encodeUtf8 k+ case e of+ Right a -> return (map T.decodeUtf8 a)+ Left _err -> return []++rdelstar :: Text -> Redis Bool+rdelstar k = rdel =<< rkeys k
+ src/Snap/Snaplet/Wordpress/Cache/Types.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}++module Snap.Snaplet.Wordpress.Cache.Types where++import Database.Redis (Redis)++data CacheBehavior = NoCache | CacheSeconds Int | CacheForever deriving (Show, Eq)+type RunRedis = forall a. Redis a -> IO a
+ src/Snap/Snaplet/Wordpress/Field.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}++module Snap.Snaplet.Wordpress.Field where++import Control.Applicative ((<$>))+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T+import Heist+import Heist.Compiled++-- TODO(dbp 2014-10-14): date should be parsed and nested.+data Field m = F Text -- A single flat field+ | P Text (RuntimeSplice m Text -> Splice m) -- A customly parsed flat field+ | N Text [Field m] -- A nested object field+ | M Text [Field m] -- A list field, where each element is an object++mergeFields :: (Functor m, Monad m) => [Field m] -> [Field m] -> [Field m]+mergeFields fo [] = fo+mergeFields fo (f:fs) = mergeFields (overrideInList False f fo) fs+ where overrideInList :: (Functor m, Monad m) => Bool -> Field m -> [Field m] -> [Field m]+ overrideInList False fl [] = [fl]+ overrideInList True _ [] = []+ overrideInList v fl (m:ms) = (if matchesName m fl+ then mergeField m fl : (overrideInList True fl ms)+ else m : (overrideInList v fl ms))+ matchesName a b = getName a == getName b+ getName (F t) = t+ getName (P t _) = t+ getName (N t _) = t+ getName (M t _) = t+ mergeField (N _ left) (N nm right) = N nm (mergeFields left right)+ mergeField (M _ left) (N nm right) = N nm (mergeFields left right)+ mergeField (N _ left) (M nm right) = M nm (mergeFields left right)+ mergeField (M _ left) (M nm right) = M nm (mergeFields left right)+ mergeField _ right = right++instance (Functor m, Monad m) => Show (Field m) where+ show (F t) = "F(" <> T.unpack t <> ")"+ show (P t _) = "P(" <> T.unpack t <> ",{code})"+ show (N t n) = "N(" <> T.unpack t <> "," <> show n <> ")"+ show (M t m) = "M(" <> T.unpack t <> "," <> show m <> ")"++postFields :: (Functor m, Monad m) => [Field m]+postFields = [F "ID"+ ,F "title"+ ,F "status"+ ,F "type"+ ,N "author" [F "ID",F "name",F "first_name",F "last_name",F "description"]+ ,F "content"+ ,P "date" dateSplice+ ,F "slug"+ ,F "excerpt"+ ,N "custom_fields" [F "test"]+ ,N "featured_image" [F "content"+ ,F "source"+ ,N "attachment_meta" [F "width"+ ,F "height"+ ,N "sizes" [N "thumbnail" [F "width"+ ,F "height"+ ,F "url"]+ ]]]+ ,N "terms" [M "category" [F "ID", F "name", F "slug", F "count"]+ ,M "post_tag" [F "ID", F "name", F "slug", F "count"]]+ ]++dateSplice :: (Functor m, Monad m) => RuntimeSplice m Text -> Splice m+dateSplice d = withSplices runChildren splices (parseDate <$> d)+ where splices = do "wpYear" ## pureSplice $ textSplice fst3+ "wpMonth" ## pureSplice $ textSplice snd3+ "wpDay" ## pureSplice $ textSplice trd3+ parseDate :: Text -> (Text,Text,Text)+ parseDate = tuplify . T.splitOn "-" . T.takeWhile (/= 'T')+ tuplify (y:m:d:_) = (y,m,d)+ fst3 (a,_,_) = a+ snd3 (_,a,_) = a+ trd3 (_,_,a) = a
+ src/Snap/Snaplet/Wordpress/HTTP.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}++module Snap.Snaplet.Wordpress.HTTP where++import Control.Lens+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL+import qualified Network.Wreq as W++newtype Requester = Requester { unRequester :: Text -> [(Text, Text)] -> IO Text }++wreqRequester :: (Text -> IO ())+ -> Text+ -> Text+ -> Requester+wreqRequester logger user passw =+ Requester $ \u ps -> do let opts = (W.defaults & W.params .~ ps+ & W.auth .~ W.basicAuth user' pass')+ logger $ "wreq: " <> u <> " with params: " <>+ (T.intercalate "&" . map (\(a,b) -> a <> "=" <> b) $ ps)+ r <- W.getWith opts (T.unpack u)+ return $ TL.toStrict . TL.decodeUtf8 $ r ^. W.responseBody+ where user' = T.encodeUtf8 user+ pass' = T.encodeUtf8 passw+
+ src/Snap/Snaplet/Wordpress/Init.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module Snap.Snaplet.Wordpress.Init where++import Control.Concurrent.MVar+import Control.Lens hiding (children)+import qualified Data.Configurator as C+import Data.Default+import qualified Data.Map as Map+import Data.Monoid+import qualified Database.Redis as R+import Heist+import Snap hiding (path, rqURI)+import Snap.Snaplet.Heist (Heist, addConfig)+import Snap.Snaplet.RedisDB (RedisDB)+import qualified Snap.Snaplet.RedisDB as RDB++import Snap.Snaplet.Wordpress.Cache+import Snap.Snaplet.Wordpress.Cache.Types+import Snap.Snaplet.Wordpress.HTTP+import Snap.Snaplet.Wordpress.Internal+import Snap.Snaplet.Wordpress.Splices+import Snap.Snaplet.Wordpress.Types++instance Default (WordpressConfig m) where+ def = WordpressConfig "http://127.0.0.1/wp-json" Nothing (CacheSeconds 600) [] Nothing++initWordpress :: Snaplet (Heist b)+ -> Snaplet RedisDB+ -> WPLens b+ -> SnapletInit b (Wordpress b)+initWordpress = initWordpress' def++initWordpress' :: WordpressConfig (Handler b b)+ -> Snaplet (Heist b)+ -> Snaplet RedisDB+ -> WPLens b+ -> SnapletInit b (Wordpress b)+initWordpress' wpconf heist redis wpLens =+ makeSnaplet "wordpress" "" Nothing $+ do conf <- getSnapletUserConfig+ let logf = wpLogInt $ wpConfLogger wpconf+ wpReq <- case wpConfRequester wpconf of+ Nothing -> do u <- liftIO $ C.require conf "username"+ p <- liftIO $ C.require conf "password"+ return $ wreqRequester logf u p+ Just r -> return r+ active <- liftIO $ newMVar Map.empty+ let rrunRedis = R.runRedis $ view (snapletValue . RDB.redisConnection) redis+ let wpInt = WordpressInt{ wpRequest = wpRequestInt wpReq (wpConfEndpoint wpconf)+ , wpCacheSet = wpCacheSetInt rrunRedis (wpConfCacheBehavior wpconf)+ , wpCacheGet = wpCacheGetInt rrunRedis (wpConfCacheBehavior wpconf)+ , startReqMutex = startReqMutexInt active+ , stopReqMutex = stopReqMutexInt active }+ let wp = Wordpress{ requestPostSet = Nothing+ , wpExpireAggregates = wpExpireAggregatesInt rrunRedis+ , wpExpirePost = wpExpirePostInt rrunRedis+ , cachingGet = cachingGetInt wpInt+ , cachingGetRetry = cachingGetRetryInt wpInt+ , cachingGetError = cachingGetErrorInt wpInt+ , cacheInternals = wpInt+ , wpLogger = logf+ }+ let extraFields = wpConfExtraFields wpconf+ addConfig heist $ set scCompiledSplices (wordpressSplices wp extraFields wpLens) mempty+ return wp
+ src/Snap/Snaplet/Wordpress/Internal.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Snap.Snaplet.Wordpress.Internal where++import Data.Monoid ((<>))+import qualified Data.Set as Set+import Data.Text (Text)++import Snap.Snaplet.Wordpress.HTTP+import Snap.Snaplet.Wordpress.Types+import Snap.Snaplet.Wordpress.Utils++wpRequestInt :: Requester -> Text -> WPKey -> IO Text+wpRequestInt runHTTP endpt key =+ case key of+ TaxDictKey resName -> req ("/taxonomies/" <> resName <> "/terms") []+ PostByPermalinkKey year month slug ->+ req "/posts" [("filter[year]", year)+ ,("filter[monthnum]", month)+ ,("filter[name]", slug)]+ PostsKey{} -> req "/posts" (buildParams key)+ PostKey i -> req ("/posts/" <> tshow i) []+ AuthorKey i -> req ("/users/" <> tshow i) []+ where req path params = (unRequester runHTTP) (endpt <> path) params++buildParams :: WPKey -> [(Text, Text)]+buildParams (PostsKey filters) = params+ where params = Set.toList $ Set.map mkFilter filters+ mkFilter (TagFilter (TaxPlusId i)) = ("filter[tag__in]", tshow i)+ mkFilter (TagFilter (TaxMinusId i)) = ("filter[tag__not_in]", tshow i)+ mkFilter (CatFilter (TaxPlusId i)) = ("filter[category__in]", tshow i)+ mkFilter (CatFilter (TaxMinusId i)) = ("filter[category__not_in]", tshow i)+ mkFilter (NumFilter num) = ("filter[posts_per_page]", tshow num)+ mkFilter (OffsetFilter offset) = ("filter[offset]", tshow offset)++wpLogInt :: Maybe (Text -> IO ()) -> Text -> IO ()+wpLogInt logger msg = case logger of+ Nothing -> return ()+ Just f -> f msg
+ src/Snap/Snaplet/Wordpress/Posts.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Snap.Snaplet.Wordpress.Posts where++import Data.Aeson+import qualified Data.HashMap.Strict as M+import Data.Maybe (fromMaybe)+import Data.Ratio++import Snap.Snaplet.Wordpress.Utils++extractPostId :: Object -> (Int, Object)+extractPostId p = let i = M.lookup "ID" p+ is = case i of+ Just (String n) -> readSafe n+ Just (Number n) ->+ let rat = toRational n in+ case denominator rat of+ 1 -> Just $ fromInteger (numerator rat)+ _ -> Nothing+ _ -> Nothing+ id' = fromMaybe 0 is in+ (id', p)++extractPostIds :: [Object] -> [(Int, Object)]+extractPostIds = map extractPostId
+ src/Snap/Snaplet/Wordpress/Queries.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Snap.Snaplet.Wordpress.Queries where++import Data.Monoid+import Data.Text (Text)+import Snap hiding (path, rqURI)++import Snap.Snaplet.Wordpress.Types+import Snap.Snaplet.Wordpress.Utils++lookupTaxDict :: WPKey -> Wordpress b -> IO (TaxSpec a -> TaxSpecId a)+lookupTaxDict key@(TaxDictKey resName) Wordpress{..} =+ do res <- decodeJsonErr <$> cachingGetError key+ return (getSpecId $ TaxDict res resName)++getSpecId :: TaxDict a -> TaxSpec a -> TaxSpecId a+getSpecId taxDict spec =+ case spec of+ TaxPlus slug -> TaxPlusId $ idFor taxDict slug+ TaxMinus slug -> TaxMinusId $ idFor taxDict slug+ where+ idFor :: TaxDict a -> Text -> Int+ idFor (TaxDict{..}) slug =+ case filter (\(TaxRes (_,s)) -> s == slug) dict of+ [] -> terror $ "Couldn't find " <> desc <> ": " <> slug+ (TaxRes (i,_):_) -> i
+ src/Snap/Snaplet/Wordpress/Splices.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}++module Snap.Snaplet.Wordpress.Splices where++import Control.Lens hiding (children)+import Data.Aeson hiding (decode, encode)+import qualified Data.Attoparsec.Text as A+import Data.Char (toUpper)+import qualified Data.HashMap.Strict as M+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet+import Data.Map.Syntax+import Data.Maybe (fromJust, fromMaybe)+import Data.Monoid+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Vector as V+import Heist+import Heist.Compiled+import Heist.Compiled.LowLevel+import Snap hiding (path, rqURI)+import qualified Text.XmlHtml as X++import Snap.Snaplet.Wordpress.Field+import Snap.Snaplet.Wordpress.Posts+import Snap.Snaplet.Wordpress.Queries+import Snap.Snaplet.Wordpress.Types+import Snap.Snaplet.Wordpress.Utils++wordpressSplices :: Wordpress b+ -> [Field (Handler b b)]+ -> WPLens b+ -> Splices (Splice (Handler b b))+wordpressSplices wp extraFields wpLens =+ do "wpPosts" ## wpPostsSplice wp extraFields wpLens+ "wpPostByPermalink" ## wpPostByPermalinkSplice extraFields wpLens+ "wpNoPostDuplicates" ## wpNoPostDuplicatesSplice wpLens+ "wp" ## wpPrefetch wp++wpPostsSplice :: Wordpress b+ -> [Field (Handler b b)]+ -> WPLens b+ -> Splice (Handler b b)+wpPostsSplice wp extraFields wpLens =+ do promise <- newEmptyPromise+ outputChildren <- manyWithSplices runChildren (postSplices extraFields)+ (getPromise promise)+ postsQuery <- parseQueryNode <$> getParamNode+ tagDict <- lift $ lookupTaxDict (TaxDictKey "post_tag") wp+ catDict <- lift $ lookupTaxDict (TaxDictKey "category") wp+ let wpKey = mkWPKey tagDict catDict postsQuery+ return $ yieldRuntime $+ do res <- liftIO $ cachingGetRetry wp wpKey+ case (decode res) of+ Just posts -> do let postsW = extractPostIds posts+ Wordpress{..} <- lift (use (wpLens . snapletValue))+ let postsND = take (qlimit postsQuery) . noDuplicates requestPostSet $ postsW+ lift $ addPostIds wpLens (map fst postsND)+ putPromise promise (map snd postsND)+ codeGen outputChildren+ Nothing -> codeGen (yieldPureText "")+ where noDuplicates :: Maybe IntSet -> [(Int, Object)] -> [(Int, Object)]+ noDuplicates Nothing = id+ noDuplicates (Just postSet) = filter (\(i,_) -> IntSet.notMember i postSet)++wpPostByPermalinkSplice :: [Field (Handler b b)]+ -> WPLens b+ -> Splice (Handler b b)+wpPostByPermalinkSplice extraFields wpLens =+ do promise <- newEmptyPromise+ outputChildren <- withSplices runChildren (postSplices extraFields) (getPromise promise)+ return $ yieldRuntime $+ do mperma <- (parsePermalink . rqURI) <$> lift getRequest+ case mperma of+ Nothing -> codeGen (yieldPureText "")+ Just (year, month, slug) ->+ do res <- lift $ with wpLens $ wpGetPost (PostByPermalinkKey year month slug)+ case res of+ Just post -> do putPromise promise post+ codeGen outputChildren+ _ -> codeGen (yieldPureText "")++wpNoPostDuplicatesSplice :: WPLens b+ -> Splice (Handler b b)+wpNoPostDuplicatesSplice wpLens =+ return $ yieldRuntime $+ do w@Wordpress{..} <- lift $ use (wpLens . snapletValue)+ case requestPostSet of+ Nothing -> lift $ assign (wpLens . snapletValue)+ w{requestPostSet = (Just IntSet.empty)}+ Just _ -> return ()+ codeGen $ yieldPureText ""++postSplices :: (Functor m, Monad m) => [Field m] -> Splices (RuntimeSplice m Object -> Splice m)+postSplices extra = mconcat (map buildSplice (mergeFields postFields extra))+ where buildSplice (F n) =+ transformName n ## pureSplice . textSplice $ getText n+ buildSplice (P n splice) =+ transformName n ## \o -> splice (getText n <$> o)+ buildSplice (N n fs) = transformName n ## \o ->+ withSplices runChildren+ (mconcat $ map buildSplice fs)+ (unObj . fromJust . M.lookup n <$> o)+ buildSplice (M n fs) = transformName n ## \o ->+ manyWithSplices runChildren+ (mconcat $ map buildSplice fs)+ (unArray . fromJust . M.lookup n <$> o)+ unObj (Object o) = o+ unArray (Array v) = map unObj $ V.toList v+ getText n o = case M.lookup n o of+ Just (String t) -> t+ Just (Number i) -> T.pack $ show i+ _ -> ""++-- * -- Internal -- * --++parseQueryNode :: X.Node -> WPQuery+parseQueryNode n =+ mkPostsQuery (readSafe =<< X.getAttribute "limit" n)+ (readSafe =<< X.getAttribute "num" n)+ (readSafe =<< X.getAttribute "offset" n)+ (readSafe =<< X.getAttribute "page" n)+ (readSafe =<< X.getAttribute "tags" n)+ (readSafe =<< X.getAttribute "categories" n)++mkPostsQuery :: Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int+ -> Maybe (TaxSpecList TagType) -> Maybe (TaxSpecList CatType)+ -> WPQuery+mkPostsQuery l n o p ts cs =+ WPPostsQuery{ qlimit = fromMaybe 20 l+ , qnum = fromMaybe 20 n+ , qoffset = fromMaybe 0 o+ , qpage = fromMaybe 1 p+ , qtags = fromMaybe (TaxSpecList []) ts+ , qcats = fromMaybe (TaxSpecList []) cs+ }+++wpPrefetch :: Wordpress b+ -> Splice (Handler b b)+wpPrefetch wp =+ do n <- getParamNode+ childrenRes <- runChildren+ tagDict <- lift $ lookupTaxDict (TaxDictKey "post_tag") wp+ catDict <- lift $ lookupTaxDict (TaxDictKey "category") wp+ let wpKeys = findPrefetchables tagDict catDict n+ return $ yieldRuntime $+ do void $ liftIO $ concurrently $ map (cachingGet wp) wpKeys+ codeGen childrenRes++findPrefetchables :: (TaxSpec TagType -> TaxSpecId TagType)+ -> (TaxSpec CatType -> TaxSpecId CatType)+ -> X.Node+ -> [WPKey]+findPrefetchables tdict cdict e@(X.Element "wpPosts" _ children) =+ concat (map (findPrefetchables tdict cdict) children) <>+ [mkWPKey tdict cdict $ parseQueryNode e]+findPrefetchables tdict cdict (X.Element _ _ children) =+ concat (map (findPrefetchables tdict cdict) children)+findPrefetchables _ _ _ = []++mkWPKey :: (TaxSpec TagType -> TaxSpecId TagType)+ -> (TaxSpec CatType -> TaxSpecId CatType)+ -> WPQuery+ -> WPKey+mkWPKey tagDict catDict WPPostsQuery{..} =+ let page = if qpage < 1 then 1 else qpage+ offset = qnum * (page - 1) + qoffset+ tags = map tagDict $ unTaxSpecList qtags+ cats = map catDict $ unTaxSpecList qcats+ in PostsKey (Set.fromList $ [ NumFilter qnum , OffsetFilter offset]+ ++ map TagFilter tags ++ map CatFilter cats)++parsePermalink :: Text -> Maybe (Text, Text, Text)+parsePermalink = either (const Nothing) Just . A.parseOnly parser . T.reverse+ where parser = do _ <- A.option ' ' (A.char '/')+ guls <- A.many1 (A.letter <|> A.char '-')+ _ <- A.char '/'+ htnom <- A.count 2 A.digit+ _ <- A.char '/'+ raey <- A.count 4 A.digit+ _ <- A.char '/'+ return (T.reverse $ T.pack raey+ ,T.reverse $ T.pack htnom+ ,T.reverse $ T.pack guls)++wpGetPost :: WPKey -> Handler b (Wordpress b) (Maybe Object)+wpGetPost wpKey =+ do wp <- view snapletValue <$> getSnapletState+ liftIO $ getPost wp wpKey++getPost :: Wordpress b -> WPKey -> IO (Maybe Object)+getPost Wordpress{..} wpKey = do decodePost <$> cachingGetRetry wpKey+ where decodePost :: Text -> Maybe Object+ decodePost t =+ do post' <- decodeJson t+ case post' of+ Just (post:_) -> Just post+ _ -> Nothing++transformName :: Text -> Text+transformName = T.append "wp" . snd . T.foldl f (True, "")+ where f (True, rest) next = (False, T.snoc rest (toUpper next))+ f (False, rest) '_' = (True, rest)+ f (False, rest) '-' = (True, rest)+ f (False, rest) next = (False, T.snoc rest next)++-- Move this into Init.hs (should retrieve from Wordpress data structure)+addPostIds :: WPLens b -> [Int] -> Handler b b ()+addPostIds wpLens ids =+ do w@Wordpress{..} <- use (wpLens . snapletValue)+ assign (wpLens . snapletValue)+ w{requestPostSet = ((`IntSet.union` (IntSet.fromList ids)) <$> requestPostSet) }
+ src/Snap/Snaplet/Wordpress/Types.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Snap.Snaplet.Wordpress.Types where++import Control.Lens hiding (children)+import Data.Aeson (FromJSON, Value (..),+ parseJSON, (.:))+import Data.IntSet (IntSet)+import Data.List (intercalate)+import Data.Maybe (catMaybes, isJust)+import Data.Set (Set)+import Data.Text (Text)+import qualified Data.Text as T+import Snap++import Snap.Snaplet.Wordpress.Cache.Types+import Snap.Snaplet.Wordpress.Field+import Snap.Snaplet.Wordpress.HTTP+import Snap.Snaplet.Wordpress.Utils++data Wordpress b =+ Wordpress { requestPostSet :: Maybe IntSet+ , wpExpireAggregates :: IO Bool+ , wpExpirePost :: WPKey -> IO Bool+ , cachingGet :: WPKey -> IO (Maybe Text)+ , cachingGetRetry :: WPKey -> IO Text+ , cachingGetError :: WPKey -> IO Text+ , wpLogger :: Text -> IO ()+ , cacheInternals :: WordpressInt b+ }++type WPLens b = Lens b b (Snaplet (Wordpress b)) (Snaplet (Wordpress b))++data WordpressConfig m =+ WordpressConfig { wpConfEndpoint :: Text+ , wpConfRequester :: Maybe Requester+ , wpConfCacheBehavior :: CacheBehavior+ , wpConfExtraFields :: [Field m]+ , wpConfLogger :: Maybe (Text -> IO ())+ }++data WordpressInt b =+ WordpressInt { wpCacheGet :: WPKey -> IO (Maybe Text)+ , wpCacheSet :: WPKey -> Text -> IO ()+ , startReqMutex :: WPKey -> IO Bool+ , wpRequest :: WPKey -> IO Text+ , stopReqMutex :: WPKey -> IO ()+ }++data TaxSpec a = TaxPlus Text | TaxMinus Text deriving (Eq, Ord)++data TaxSpecId a = TaxPlusId Int | TaxMinusId Int deriving (Eq, Show, Ord)++data CatType+data TagType++instance Show (TaxSpec a) where+ show (TaxPlus t) = "+" ++ (T.unpack t)+ show (TaxMinus t) = "-" ++ (T.unpack t)++newtype TaxRes a = TaxRes (Int, Text)++instance FromJSON (TaxRes a) where+ parseJSON (Object o) = do meta <- o .: "meta"+ links <- meta .: "links"+ url <- links .: "self"+ slug <- o .: "slug"+ let id = last $ T.splitOn "/" url+ case readSafe id of+ Nothing -> fail "FromJSON TaxRes: Could not get ID from self link"+ Just i -> return $ TaxRes (i, slug)+ -- NOTE(dbp 2014-12-16):+ -- See https://github.com/WP-API/WP-API/issues/726+ -- The ID is currently wrong. So use the self-link+ -- instead (which should always be correct. Correcting+ -- the ID by 1, on the other hand, would break when upstream+ -- is fixed).+ -- But in theory, the following would be all that's needed.+ -- TaxRes <$> ((,) <$> o .: "ID" <*> o .: "slug")+ parseJSON _ = mzero++data TaxDict a = TaxDict {dict :: [TaxRes a], desc :: Text}++type Year = Text+type Month = Text+type Slug = Text+data Filter = TagFilter (TaxSpecId TagType)+ | CatFilter (TaxSpecId CatType)+ | NumFilter Int+ | OffsetFilter Int+ deriving (Eq, Ord)++instance Show Filter where+ show (TagFilter t) = "tag_" ++ show t+ show (CatFilter t) = "cat_" ++ show t+ show (NumFilter n) = "num_" ++ show n+ show (OffsetFilter n) = "offset_" ++ show n++data WPKey = PostKey Int+ | PostByPermalinkKey Year Month Slug+ | PostsKey (Set Filter)+ | AuthorKey Int+ | TaxDictKey Text+ deriving (Eq, Show, Ord)++tagChars :: String+tagChars = ['a'..'z'] ++ "-"++digitChars :: String+digitChars = ['0'..'9']++instance Read (TaxSpec a) where+ readsPrec _ ('+':cs) | not (null cs) && all (`elem` tagChars) cs = [(TaxPlus (T.pack cs), "")]+ readsPrec _ ('-':cs) | not (null cs) && all (`elem` tagChars) cs = [(TaxMinus (T.pack cs), "")]+ readsPrec _ cs | not (null cs) && all (`elem` tagChars) cs = [(TaxPlus (T.pack cs), "")]+ readsPrec _ _ = []++instance Read (TaxSpecId a) where+ readsPrec _ ('+':cs) | not (null cs) && all (`elem` digitChars) cs = [(TaxPlusId (read cs), "")]+ readsPrec _ ('-':cs) | not (null cs) && all (`elem` digitChars) cs = [(TaxMinusId (read cs), "")]+ readsPrec _ cs | not (null cs) && all (`elem` digitChars) cs = [(TaxPlusId (read cs), "")]+ readsPrec _ _ = []++newtype TaxSpecList a = TaxSpecList { unTaxSpecList :: [TaxSpec a]} deriving (Eq, Ord)++instance Show (TaxSpecList a) where+ show (TaxSpecList ts) = intercalate "," (map show ts)++instance Read (TaxSpecList a) where+ readsPrec _ ts = let vs = map (readSafe) $ T.splitOn "," $ T.pack ts in+ if all isJust vs+ then [(TaxSpecList $ catMaybes vs, "")]+ else []++data WPQuery = WPPostsQuery{ qlimit :: Int+ , qnum :: Int+ , qoffset :: Int+ , qpage :: Int+ , qtags :: TaxSpecList TagType+ , qcats :: TaxSpecList CatType}
+ src/Snap/Snaplet/Wordpress/Utils.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedStrings #-}++module Snap.Snaplet.Wordpress.Utils where++import Control.Concurrent as CC+import qualified Control.Concurrent.Async as CC+import Data.Aeson (FromJSON, ToJSON)+import qualified Data.Aeson as J+import Data.Maybe+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL+import qualified Snap as SNAP++readSafe :: Read a => Text -> Maybe a+readSafe = fmap fst . listToMaybe . reads . T.unpack++tshow :: Show a => a -> Text+tshow = T.pack . show++terror :: Text -> a+terror = error . T.unpack++(=<<<) :: Monad r => (a -> r (Maybe b)) -> r (Maybe a) -> r (Maybe b)+f =<<< g = maybe (return Nothing) f =<< g++decode :: (FromJSON a) => Text -> Maybe a+decode = J.decodeStrict . T.encodeUtf8++encode :: (ToJSON a) => a -> Text+encode = TL.toStrict . TL.decodeUtf8 . J.encode++decodeJsonErr :: FromJSON a => Text -> a+decodeJsonErr res = case decode res of+ Nothing -> terror $ "Unparsable JSON: " <> res+ Just val -> val++decodeJson :: FromJSON a => Text -> Maybe a+decodeJson res = decode res++-- * -- IO Utilities -- * --+performOnJust :: (o -> IO ()) -> Maybe o -> IO ()+performOnJust = maybe (return ())++retryUnless :: IO (Maybe a) -> IO a+retryUnless action =+ do ma <- action+ case ma of+ Just r -> return r+ Nothing -> do CC.threadDelay 100000+ retryUnless action++errorUnless :: Text -> IO (Maybe a) -> IO a+errorUnless msg action =+ do ma <- action+ case ma of+ Just a -> return a+ Nothing -> error $ T.unpack msg++concurrently :: [IO a] -> IO [a]+concurrently [] = return []+concurrently [a] =+ do res <- a+ return [res]+concurrently (a:as) =+ do (r1, rs) <- CC.concurrently a (concurrently as)+ return (r1:rs)++rqURI :: SNAP.Request -> Text+rqURI = T.decodeUtf8 . SNAP.rqURI