diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/snaplet-wordpress.cabal b/snaplet-wordpress.cabal new file mode 100644 --- /dev/null +++ b/snaplet-wordpress.cabal @@ -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 diff --git a/spec/Main.hs b/spec/Main.hs new file mode 100644 --- /dev/null +++ b/spec/Main.hs @@ -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 "" $ do + ("", enc [article1]) `shouldRenderTo` "Foo bar" + ("", enc [article1]) `shouldRenderTo` "1" + ("", enc [article1]) `shouldRenderTo` "summary" + describe "" $ do + ("", enc [article1]) + `shouldRenderTo` "Foo bar" + ("", enc [article1]) + `shouldRenderTo` "Foo barFoo bar" + ("", enc [article1]) + `shouldRenderTo` "Foo barFoo bar" + ("", enc [article1]) + `shouldRenderTo` "Foo barFoo bar" +{- describe "" $ do + shouldRenderAtUrl "/2009/10/the-post/" + "" + "The post" + shouldRenderAtUrl "/posts/2009/10/the-post/" + "" + "The post" + shouldRenderAtUrl "/posts/2009/10/the-post" + "" + "The post" + shouldRenderAtUrl "/2009/10/the-post/" + ": " + "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/" + "" + "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 " $ do + shouldQueryTo + "" + ["/posts?filter[offset]=0&filter[posts_per_page]=20"] + shouldQueryTo + "" + ["/posts?filter[offset]=0&filter[posts_per_page]=20"] + shouldQueryTo + "" + ["/posts?filter[offset]=1&filter[posts_per_page]=20"] + shouldQueryTo + "" + ["/posts?filter[offset]=0&filter[posts_per_page]=20"] + shouldQueryTo + "" + ["/posts?filter[offset]=0&filter[posts_per_page]=20"] + shouldQueryTo + "" + ["/posts?filter[offset]=20&filter[posts_per_page]=20"] + shouldQueryTo + "" + ["/posts?filter[offset]=0&filter[posts_per_page]=2"] + shouldQueryTo + "" + ["/posts?filter[offset]=2&filter[posts_per_page]=2"] + shouldQueryTo + "" + ["/posts?filter[offset]=2&filter[posts_per_page]=1"] + shouldQueryTo + "" + ["/posts?filter[offset]=0&filter[posts_per_page]=20&filter[tag__in]=177"] + shouldQueryTo + "" + ["/posts?filter[offset]=0&filter[posts_per_page]=20&filter[tag__not_in]=177"] + shouldQueryTo + "" + ["/posts?filter[offset]=0&filter[posts_per_page]=20&filter[tag__in]=177&filter[tag__not_in]=160"] + shouldQueryTo + "" + ["/posts?filter[offset]=0&filter[posts_per_page]=20&filter[tag__in]=160&filter[tag__in]=177"] + shouldQueryTo + "" + ["/posts?filter[category__in]=159&filter[offset]=0&filter[posts_per_page]=20"] + shouldQueryTo + "" + ["/posts?filter[category__not_in]=159&filter[offset]=0&filter[posts_per_page]=20"] + shouldQueryTo + "
" + (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", "") + ,("author-date", "/") + ,("fields", "") + ,("extra-fields", "") + ] + ) $ + 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 diff --git a/src/Snap/Snaplet/Wordpress.hs b/src/Snap/Snaplet/Wordpress.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Wordpress.hs @@ -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 diff --git a/src/Snap/Snaplet/Wordpress/Cache.hs b/src/Snap/Snaplet/Wordpress/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Wordpress/Cache.hs @@ -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 diff --git a/src/Snap/Snaplet/Wordpress/Cache/Redis.hs b/src/Snap/Snaplet/Wordpress/Cache/Redis.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Wordpress/Cache/Redis.hs @@ -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 diff --git a/src/Snap/Snaplet/Wordpress/Cache/Types.hs b/src/Snap/Snaplet/Wordpress/Cache/Types.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Wordpress/Cache/Types.hs @@ -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 diff --git a/src/Snap/Snaplet/Wordpress/Field.hs b/src/Snap/Snaplet/Wordpress/Field.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Wordpress/Field.hs @@ -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 diff --git a/src/Snap/Snaplet/Wordpress/HTTP.hs b/src/Snap/Snaplet/Wordpress/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Wordpress/HTTP.hs @@ -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 + diff --git a/src/Snap/Snaplet/Wordpress/Init.hs b/src/Snap/Snaplet/Wordpress/Init.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Wordpress/Init.hs @@ -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 diff --git a/src/Snap/Snaplet/Wordpress/Internal.hs b/src/Snap/Snaplet/Wordpress/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Wordpress/Internal.hs @@ -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 diff --git a/src/Snap/Snaplet/Wordpress/Posts.hs b/src/Snap/Snaplet/Wordpress/Posts.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Wordpress/Posts.hs @@ -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 diff --git a/src/Snap/Snaplet/Wordpress/Queries.hs b/src/Snap/Snaplet/Wordpress/Queries.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Wordpress/Queries.hs @@ -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 diff --git a/src/Snap/Snaplet/Wordpress/Splices.hs b/src/Snap/Snaplet/Wordpress/Splices.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Wordpress/Splices.hs @@ -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) } diff --git a/src/Snap/Snaplet/Wordpress/Types.hs b/src/Snap/Snaplet/Wordpress/Types.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Wordpress/Types.hs @@ -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} diff --git a/src/Snap/Snaplet/Wordpress/Utils.hs b/src/Snap/Snaplet/Wordpress/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Wordpress/Utils.hs @@ -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