diff --git a/offset.cabal b/offset.cabal index 5a5e0e3..bbfc933 100644 --- a/offset.cabal +++ b/offset.cabal @@ -21,13 +21,17 @@ library , Web.Offset.Field , Web.Offset.Init , Web.Offset.Splices - , Web.Offset.Queries + , Web.Offset.Splices.Helpers , Web.Offset.HTTP , Web.Offset.Cache , Web.Offset.Cache.Types , Web.Offset.Cache.Redis - , Web.Offset.Posts , Web.Offset.Utils + , Web.Offset.WordPress.Field + , Web.Offset.WordPress.Posts + , Web.Offset.WordPress.Queries + , Web.Offset.WordPress.Splices + , Web.Offset.WordPress.Types -- other-extensions: build-depends: aeson , base < 4.9 @@ -69,11 +73,15 @@ Test-Suite test-offset , Web.Offset.HTTP , Web.Offset.Init , Web.Offset.Internal - , Web.Offset.Posts - , Web.Offset.Queries , Web.Offset.Splices + , Web.Offset.Splices.Helpers , Web.Offset.Types , Web.Offset.Utils + , Web.Offset.WordPress.Field + , Web.Offset.WordPress.Posts + , Web.Offset.WordPress.Queries + , Web.Offset.WordPress.Splices + , Web.Offset.WordPress.Types build-depends: base , aeson , async diff --git a/spec/Common.hs b/spec/Common.hs index bba7b91..fb16db7 100644 --- a/spec/Common.hs +++ b/spec/Common.hs @@ -7,25 +7,25 @@ module Common where import Control.Concurrent.MVar -import Control.Lens hiding ((.=)) -import Control.Monad (void) -import Control.Monad.State (StateT, evalStateT) -import qualified Control.Monad.State as S -import Control.Monad.Trans (liftIO) -import Data.Aeson hiding (Success) +import Control.Lens hiding ((.=)) +import Control.Monad (void) +import Control.Monad.State (StateT, evalStateT) +import qualified Control.Monad.State as S +import Control.Monad.Trans (liftIO) +import Data.Aeson hiding (Success) import Data.Default -import qualified Data.HashMap.Strict as HM -import qualified Data.Map as M +import qualified Data.HashMap.Strict as HM +import qualified Data.Map as M 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 Database.Redis as R -import Network.Wai (defaultRequest, rawPathInfo) -import Prelude hiding ((++)) +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 Database.Redis as R +import Network.Wai (defaultRequest, rawPathInfo) +import Prelude hiding ((++)) import Test.Hspec import Web.Fn import Web.Larceny @@ -33,16 +33,17 @@ import Web.Larceny import Web.Offset import Web.Offset.Cache.Redis import Web.Offset.Types +import Web.Offset.WordPress.Types ---------------------------------------------------------- -- Section 1: Example application used for testing. -- ---------------------------------------------------------- -data Ctxt = Ctxt { _req :: FnRequest - , _redis :: R.Connection - , _wordpress :: Wordpress Ctxt - , _wpsubs :: Substitutions Ctxt - , _lib :: Library Ctxt +data Ctxt = Ctxt { _req :: FnRequest + , _redis :: R.Connection + , _cms :: CMS Ctxt + , _cmssubs :: Substitutions Ctxt + , _lib :: Library Ctxt } makeLenses ''Ctxt @@ -119,9 +120,9 @@ tplLibrary = ,(["department"], parse "") ,(["author-date"], parse "Hello/") ,(["fields"], parse "") - ,(["custom-endpoint-object"], parse "") - ,(["custom-endpoint-array"], parse "") - ,(["custom-endpoint-enter-the-matrix"], parse "") + ,(["custom-endpoint-object"], parse "") + ,(["custom-endpoint-array"], parse "") + ,(["custom-endpoint-enter-the-matrix"], parse "") ] renderLarceny :: Ctxt -> @@ -131,7 +132,7 @@ renderLarceny ctxt name = do let tpl = M.lookup [name] tplLibrary case tpl of Just t -> do - rendered <- evalStateT (runTemplate t [name] (ctxt ^. wpsubs) tplLibrary) ctxt + rendered <- evalStateT (runTemplate t [name] (ctxt ^. cmssubs) tplLibrary) ctxt return $ Just rendered _ -> return Nothing @@ -170,17 +171,17 @@ fauxRequester mRecord rqPath rqParams = do initializer :: Either UserPassword Requester -> CacheBehavior -> Text -> IO Ctxt initializer requester cache endpoint = do rconn <- R.connect R.defaultConnectInfo - let wpconf = def { wpConfEndpoint = endpoint - , wpConfLogger = Nothing - , wpConfRequester = requester - , wpConfExtraFields = customFields - , wpConfCacheBehavior = cache + let wpconf = def { cmsConfEndpoint = endpoint + , cmsConfLogger = Nothing + , cmsConfRequest = requester + , cmsConfExtraFields = customFields + , cmsConfCacheBehavior = cache } let getUri :: StateT Ctxt IO Text getUri = do ctxt <- S.get return (T.decodeUtf8 . rawPathInfo . fst . getRequest $ ctxt) - (wp,wpSubs) <- initWordpress wpconf rconn getUri wordpress - return (Ctxt defaultFnRequest rconn wp wpSubs mempty) + (cms', cmssubs) <- initCMS wpconf rconn getUri cms + return (Ctxt defaultFnRequest rconn cms' cmssubs mempty) initFauxRequestNoCache :: IO Ctxt initFauxRequestNoCache = @@ -218,29 +219,29 @@ shouldRender :: TemplateText -> Expectation shouldRender t output = do ctxt <- initFauxRequestNoCache - let s = _wpsubs ctxt + let s = _cmssubs ctxt rendered <- evalStateT (runTemplate (toTpl t) [] s mempty) ctxt ignoreWhitespace rendered `shouldBe` ignoreWhitespace output -- Caching helpers -wpCacheGet' :: S.MonadIO m => Wordpress b -> WPKey -> m (Maybe Text) -wpCacheGet' wordpress' wpKey = do - let WordpressInt{..} = cacheInternals wordpress' - liftIO $ wpCacheGet wpKey +cmsCacheGet' :: S.MonadIO m => CMS b -> WPKey -> m (Maybe Text) +cmsCacheGet' cms' wpKey = do + let CMSInt{..} = cacheInternals cms' + liftIO $ cmsCacheGet (toCMSKey wpKey) -wpCacheSet' :: S.MonadIO m => Wordpress b -> WPKey -> Text -> m () -wpCacheSet' wordpress' wpKey o = do - let WordpressInt{..} = cacheInternals wordpress' - liftIO $ wpCacheSet wpKey o +cmsCacheSet' :: S.MonadIO m => CMS b -> WPKey -> Text -> m () +cmsCacheSet' cms' wpKey o = do + let CMSInt{..} = cacheInternals cms' + liftIO $ cmsCacheSet (toCMSKey wpKey) o -wpExpireAggregates' :: S.MonadIO m => Wordpress t -> m Bool -wpExpireAggregates' Wordpress{..} = - liftIO wpExpireAggregates +cmsExpireAggregates' :: S.MonadIO m => CMS t -> m Bool +cmsExpireAggregates' CMS{..} = + liftIO cmsExpireAggregates -wpExpirePost' :: S.MonadIO m => Wordpress t -> WPKey -> m Bool -wpExpirePost' Wordpress{..} k = - liftIO $ wpExpirePost k +cmsExpirePost' :: S.MonadIO m => CMS t -> WPKey -> m Bool +cmsExpirePost' CMS{..} wpKey = + liftIO $ cmsExpirePost (toCMSKey wpKey) {- shouldRenderAtUrlContaining' :: (TemplateName, Ctxt) @@ -250,7 +251,7 @@ shouldRenderAtUrlContaining' (template, ctxt) (url, match) = do let requestWithUrl = defaultRequest {rawPathInfo = T.encodeUtf8 url } let ctxt' = setRequest ctxt $ (\(x,y) -> (requestWithUrl, y)) defaultFnRequest - let s = _wpsubs ctxt + let s = _cmssubs ctxt rendered <- renderLarceny ctxt' template print rendered let rendered' = fromMaybe "" rendered @@ -263,10 +264,10 @@ shouldQueryTo hQuery wpQuery = it ("should query from " <> T.unpack hQuery) $ do record <- liftIO $ newMVar [] ctxt <- liftIO $ initializer - (Right $ Requester $ fauxRequester (Just record)) - NoCache - "" - let s = _wpsubs ctxt + (Right $ Requester $ fauxRequester (Just record)) + NoCache + "" + let s = _cmssubs ctxt void $ evalStateT (runTemplate (toTpl hQuery) [] s mempty) ctxt x <- liftIO $ tryTakeMVar record x `shouldBe` Just wpQuery diff --git a/spec/Main.hs b/spec/Main.hs index f027a9b..f64ce1f 100644 --- a/spec/Main.hs +++ b/spec/Main.hs @@ -3,7 +3,7 @@ {-# LANGUAGE RankNTypes #-} module Main where - + import Prelude hiding ((++)) import Control.Concurrent.MVar @@ -75,7 +75,7 @@ larcenyFillTests = do "" let ctxt' = setRequest ctxt $ (\(_,y) -> (requestWithUrl, y)) defaultFnRequest - let s = _wpsubs ctxt' + let s = _cmssubs ctxt' let tpl = toTpl " (requestWithUrl, y)) defaultFnRequest - let s = view wpsubs ctxt' + let s = view cmssubs ctxt' let tpl = toTpl "" rendered <- evalStateT (runTemplate tpl [] s mempty) ctxt' rendered `shouldBe` "Foo bar" describe "" $ it "should render an HTML comment if JSON field is null" $ - "" `shouldRender` "" - describe "" $ do + "" `shouldRender` "" + describe "" $ do it "should parse a date field with the format string it's given" $ - " \ - \ ~~ \ - \ " `shouldRender` "26~04~2013" + " \ + \ ~~ \ + \ " `shouldRender` "26~04~2013" it "should format a date field with the format strings it's given" $ - " \ - \ , \ - \ " `shouldRender` "April 26, 2013" + " \ + \ , \ + \ " `shouldRender` "April 26, 2013" it "should use default WordPress date format if none specified" $ - " \ - \ ~~ \ - \ " `shouldRender` "26~04~2013" + " \ + \ ~~ \ + \ " `shouldRender` "26~04~2013" it "should allow formatting the whole date in a single tag" $ - " \ - \ \ - \ " `shouldRender` "04/26/13" + " \ + \ \ + \ " `shouldRender` "04/26/13" -- Caching tests @@ -118,61 +118,61 @@ cacheTests = do it "should render the post even w/o json source" $ do let (Object a2) = article2 ctxt <- liftIO initNoRequestWithCache - wpCacheSet' (view wordpress ctxt) (PostByPermalinkKey "2001" "10" "the-post") + cmsCacheSet' (view cms ctxt) (PostByPermalinkKey "2001" "10" "the-post") (enc [a2]) ("single", ctxt) `shouldRenderAtUrlContaining` ("/2001/10/the-post/", "The post") describe "caching" $ do it "should find nothing for a non-existent post" $ do ctxt <- initNoRequestWithCache - p <- wpCacheGet' (view wordpress ctxt) (PostByPermalinkKey "2000" "1" "the-article") + p <- cmsCacheGet' (view cms ctxt) (PostByPermalinkKey "2000" "1" "the-article") p `shouldBe` Nothing it "should find something if there is a post in cache" $ do ctxt <- initNoRequestWithCache - void $ wpCacheSet' (view wordpress ctxt) (PostByPermalinkKey "2000" "1" "the-article") + void $ cmsCacheSet' (view cms ctxt) (PostByPermalinkKey "2000" "1" "the-article") (enc article1) - p <- wpCacheGet' (view wordpress ctxt) (PostByPermalinkKey "2000" "1" "the-article") + p <- cmsCacheGet' (view cms ctxt) (PostByPermalinkKey "2000" "1" "the-article") p `shouldBe` (Just $ enc article1) it "should not find single post after expire handler is called" $ do ctxt <- initNoRequestWithCache - void $ wpCacheSet' (view wordpress ctxt) (PostByPermalinkKey "2000" "1" "the-article") + void $ cmsCacheSet' (view cms ctxt) (PostByPermalinkKey "2000" "1" "the-article") (enc article1) - void $ wpExpirePost' (view wordpress ctxt) (PostByPermalinkKey "2000" "1" "the-article") - wpCacheGet' (view wordpress ctxt) (PostByPermalinkKey "2000" "1" "the-article") + void $ cmsExpirePost' (view cms ctxt) (PostByPermalinkKey "2000" "1" "the-article") + cmsCacheGet' (view cms ctxt) (PostByPermalinkKey "2000" "1" "the-article") >>= shouldBe Nothing it "should find post aggregates in cache" $ do ctxt <- initNoRequestWithCache let key = PostsKey (Set.fromList [NumFilter 20, OffsetFilter 0]) - void $ wpCacheSet' (view wordpress ctxt) key ("[" <> enc article1 <> "]") - void $ wpCacheGet' (view wordpress ctxt) key + void $ cmsCacheSet' (view cms ctxt) key ("[" <> enc article1 <> "]") + void $ cmsCacheGet' (view cms ctxt) key >>= shouldBe (Just $ "[" <> enc article1 <> "]") it "should not find post aggregates after expire handler is called" $ do ctxt <- initNoRequestWithCache let key = PostsKey (Set.fromList [NumFilter 20, OffsetFilter 0]) - void $ wpCacheSet' (view wordpress ctxt) key ("[" <> enc article1 <> "]") - void $ wpExpirePost' (view wordpress ctxt) (PostByPermalinkKey "2000" "1" "the-article") - wpCacheGet' (view wordpress ctxt) key + void $ cmsCacheSet' (view cms ctxt) key ("[" <> enc article1 <> "]") + void $ cmsExpirePost' (view cms ctxt) (PostByPermalinkKey "2000" "1" "the-article") + cmsCacheGet' (view cms ctxt) key >>= shouldBe Nothing it "should find single post after expiring aggregates" $ do ctxt <- initNoRequestWithCache - void $ wpCacheSet' (view wordpress ctxt) (PostByPermalinkKey "2000" "1" "the-article") + void $ cmsCacheSet' (view cms ctxt) (PostByPermalinkKey "2000" "1" "the-article") (enc article1) - void $ wpExpireAggregates' (view wordpress ctxt) - wpCacheGet' (view wordpress ctxt) (PostByPermalinkKey "2000" "1" "the-article") + void $ cmsExpireAggregates' (view cms ctxt) + cmsCacheGet' (view cms ctxt) (PostByPermalinkKey "2000" "1" "the-article") >>= shouldNotBe Nothing it "should find a different single post after expiring another" $ do ctxt <- initNoRequestWithCache let key1 = PostByPermalinkKey "2000" "1" "the-article" key2 = PostByPermalinkKey "2001" "2" "another-article" - void $ wpCacheSet' (view wordpress ctxt) key1 (enc article1) - void $ wpCacheSet' (view wordpress ctxt) key2 (enc article2) - void $ wpExpirePost' (view wordpress ctxt) (PostByPermalinkKey "2000" "1" "the-article") - wpCacheGet' (view wordpress ctxt) key2 >>= shouldBe (Just (enc article2)) + void $ cmsCacheSet' (view cms ctxt) key1 (enc article1) + void $ cmsCacheSet' (view cms ctxt) key2 (enc article2) + void $ cmsExpirePost' (view cms ctxt) (PostByPermalinkKey "2000" "1" "the-article") + cmsCacheGet' (view cms ctxt) key2 >>= shouldBe (Just (enc article2)) it "should be able to cache and retrieve post" $ do ctxt <- initNoRequestWithCache let key = PostKey 200 - wpCacheSet' (view wordpress ctxt) key (enc article1) - wpCacheGet' (view wordpress ctxt) key >>= shouldBe (Just (enc article1)) + cmsCacheSet' (view cms ctxt) key (enc article1) + cmsCacheGet' (view cms ctxt) key >>= shouldBe (Just (enc article1)) queryTests :: Spec queryTests = diff --git a/spec/Misc.hs b/spec/Misc.hs index 1c6fa45..4f9a8d3 100644 --- a/spec/Misc.hs +++ b/spec/Misc.hs @@ -9,9 +9,16 @@ import qualified Data.Text as T import Test.Hspec import Web.Offset +import Web.Offset.Types +import Web.Offset.Utils + +shouldWPTransformTo :: Text -> Text -> Spec +shouldWPTransformTo from to = + it (T.unpack ("should convert " <> from <> " to " <> to)) $ transformName (Prefix "wp") from `shouldBe` to + shouldTransformTo :: Text -> Text -> Spec shouldTransformTo from to = - it (T.unpack ("should convert " <> from <> " to " <> to)) $ transformName from `shouldBe` to + it (T.unpack ("should convert " <> from <> " to " <> to)) $ transformName DefaultPrefix from `shouldBe` to tests :: Spec tests = do @@ -40,10 +47,16 @@ tests = do `shouldBe` [N "featured_image" [N "attachment_meta" [F "standard" ,F "mag-featured"]]] describe "transformName" $ do - "ID" `shouldTransformTo` "wpID" - "title" `shouldTransformTo` "wpTitle" - "post_tag" `shouldTransformTo` "wpPostTag" - "mag-featured" `shouldTransformTo` "wpMagFeatured" + describe "with wp prefix" $ do + "ID" `shouldWPTransformTo` "wpID" + "title" `shouldWPTransformTo` "wpTitle" + "post_tag" `shouldWPTransformTo` "wpPostTag" + "mag-featured" `shouldWPTransformTo` "wpMagFeatured" + describe "without prefix" $ do + "ID" `shouldTransformTo` "cmsID" + "title" `shouldTransformTo` "cmsTitle" + "mag-featured" `shouldTransformTo` "cmsMagFeatured" + describe "tag-specs" $ do it "should parse bare tag plus" $ read "foo-bar" `shouldBe` (TaxPlus "foo-bar") diff --git a/src/Web/Offset.hs b/src/Web/Offset.hs index d88e475..01166f4 100644 --- a/src/Web/Offset.hs +++ b/src/Web/Offset.hs @@ -4,24 +4,22 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} module Web.Offset ( - Wordpress(..) - , WordpressConfig(..) + CMS(..) + , CMSConfig(..) , Requester(..) , CacheBehavior(..) - , initWordpress - , wpGetPost - , getPost + , initCMS + , cmsGetSingle + , getSingle + , CMSKey(..) , WPKey(..) , Filter(..) , transformName , TaxSpec(..) - , TagType - , CatType , TaxSpecList(..) , Field(..) , mergeFields @@ -33,4 +31,6 @@ import Web.Offset.Field import Web.Offset.HTTP import Web.Offset.Init import Web.Offset.Splices +import Web.Offset.Splices.Helpers import Web.Offset.Types +import Web.Offset.WordPress.Types diff --git a/src/Web/Offset/Cache.hs b/src/Web/Offset/Cache.hs index 2397005..75ec1f6 100644 --- a/src/Web/Offset/Cache.hs +++ b/src/Web/Offset/Cache.hs @@ -20,7 +20,7 @@ import Web.Offset.Cache.Types import Web.Offset.Types import Web.Offset.Utils -startReqMutexInt :: MVar (Map WPKey UTCTime) -> WPKey -> IO Bool +startReqMutexInt :: MVar (Map CMSKey UTCTime) -> CMSKey -> IO Bool startReqMutexInt activeMV wpKey = do now <- getCurrentTime modifyMVar activeMV $ \a -> @@ -30,16 +30,16 @@ startReqMutexInt activeMV wpKey = 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 :: MVar (Map CMSKey UTCTime) -> CMSKey -> IO () stopReqMutexInt activeMV wpKey = modifyMVar_ activeMV $ return . Map.delete wpKey -cachingGetRetryInt :: WordpressInt b -> WPKey -> IO (Either StatusCode Text) +cachingGetRetryInt :: CMSInt b -> CMSKey -> IO (Either StatusCode Text) cachingGetRetryInt wp = retryUnless . cachingGetInt wp -cachingGetErrorInt :: WordpressInt b -> WPKey -> IO (Either StatusCode Text) +cachingGetErrorInt :: CMSInt b -> CMSKey -> IO (Either StatusCode Text) cachingGetErrorInt wp wpKey = errorUnless msg (cachingGetInt wp wpKey) - where msg = "Could not retrieve " <> tshow wpKey + where msg = "Could not retrieve " <> cShow wpKey retryUnless :: IO (CacheResult a) -> IO (Either StatusCode a) retryUnless action = @@ -58,11 +58,11 @@ errorUnless _ action = Abort code -> return $ Left code Retry -> return $ Left 500 -cachingGetInt :: WordpressInt b - -> WPKey +cachingGetInt :: CMSInt b + -> CMSKey -> IO (CacheResult Text) -cachingGetInt WordpressInt{..} wpKey = - do mCached <- wpCacheGet wpKey +cachingGetInt CMSInt{..} wpKey = + do mCached <- cmsCacheGet wpKey case mCached of Just cached -> return $ Successful cached Nothing -> @@ -70,24 +70,24 @@ cachingGetInt WordpressInt{..} wpKey = if running then return Retry else - do o <- wpRequest wpKey + do o <- cmsRequest wpKey case o of Left errorCode -> return $ Abort errorCode Right jsonBlob -> do - wpCacheSet wpKey jsonBlob + cmsCacheSet wpKey jsonBlob stopReqMutex wpKey return $ Successful jsonBlob -wpCacheGetInt :: RunRedis -> CacheBehavior -> WPKey -> IO (Maybe Text) -wpCacheGetInt runRedis b = runRedis . cacheGet b . formatKey +cmsCacheGetInt :: RunRedis -> CacheBehavior -> CMSKey -> IO (Maybe Text) +cmsCacheGetInt runRedis b = runRedis . cacheGet b . cFormatKey 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) +cmsCacheSetInt :: RunRedis -> CacheBehavior -> CMSKey -> Text -> IO () +cmsCacheSetInt runRedis b key = void . runRedis . cacheSet b (cFormatKey key) cacheSet :: CacheBehavior -> Text -> Text -> Redis Bool cacheSet b k v = @@ -102,21 +102,8 @@ wpExpireAggregatesInt runRedis = runRedis expireAggregates expireAggregates :: Redis Bool expireAggregates = rdelstar "wordpress:posts:*" -wpExpirePostInt :: RunRedis -> WPKey -> IO Bool +wpExpirePostInt :: RunRedis -> CMSKey -> 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 (PageKey s) = ns "page:" <> s - format (AuthorKey n) = ns "author:" <> tshow n - format (TaxDictKey t) = ns "tax_dict:" <> t - format (TaxSlugKey tn ts) = ns "tax_slug:" <> tn <> ":" <> ts - format (EndpointKey e) = ns "endpoint:" <> e - ns k = "wordpress:" <> k +expire :: CMSKey -> Redis Bool +expire key = rdel [cFormatKey key] >> expireAggregates diff --git a/src/Web/Offset/Field.hs b/src/Web/Offset/Field.hs index 3043b60..b6bbf2b 100644 --- a/src/Web/Offset/Field.hs +++ b/src/Web/Offset/Field.hs @@ -66,50 +66,3 @@ instance Show (Field s) where show (C t p) = "C(" <> T.unpack t <> ":" <> T.unpack (T.intercalate "/" p) <> ")" show (CN t p fs) = "C(" <> T.unpack t <> "," <> T.unpack (T.intercalate "/" p) <> ","<> show fs <> ")" show (M t m) = "M(" <> T.unpack t <> "," <> show m <> ")" - -postFields :: [Field s] -postFields = [F "id" - ,C "title" ["title", "rendered"] - ,F "status" - ,F "type" - ,F "author" - ,C "content" ["content", "rendered"] - ,P "date" wpDateFill - ,F "slug" - ,C "excerpt" ["excerpt", "rendered"] - ,N "custom_fields" [F "test"] - ,N "featured_media" [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"]] - ] - -datePartSubs :: UTCTime -> Substitutions s -datePartSubs date = subs [ ("wpYear", datePartFill "%0Y" date) - , ("wpMonth", datePartFill "%m" date) - , ("wpDay", datePartFill "%d" date) - , ("wpFullDate", datePartFill "%D" date) ] - where datePartFill defaultFormat utcTime = - useAttrs (a "format") $ \mf -> - let f = fromMaybe defaultFormat mf in - textFill $ T.pack $ formatTime defaultTimeLocale (T.unpack f) utcTime - -parseWPDate :: Text -> Text -> Maybe UTCTime -parseWPDate wpFormat date = - parseTimeM False - defaultTimeLocale - (T.unpack wpFormat) - (T.unpack date) :: Maybe UTCTime - -wpDateFill :: Text -> Fill s -wpDateFill date = - let wpFormat = "%Y-%m-%dT%H:%M:%S" in - case parseWPDate wpFormat date of - Just d -> fillChildrenWith $ datePartSubs d - Nothing -> textFill $ "" diff --git a/src/Web/Offset/Init.hs b/src/Web/Offset/Init.hs index 3f9a46f..fb1162d 100644 --- a/src/Web/Offset/Init.hs +++ b/src/Web/Offset/Init.hs @@ -5,9 +5,10 @@ module Web.Offset.Init where import Control.Concurrent.MVar import Control.Monad.State -import qualified Data.Map as Map -import Data.Text (Text) -import qualified Database.Redis as R +import qualified Data.Map as Map +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Database.Redis as R import Web.Larceny import Web.Offset.Cache @@ -15,34 +16,36 @@ import Web.Offset.HTTP import Web.Offset.Internal import Web.Offset.Splices import Web.Offset.Types +import Web.Offset.Utils +import Web.Offset.WordPress.Splices -initWordpress :: WordpressConfig s - -> R.Connection - -> StateT s IO Text - -> WPLens b s - -> IO (Wordpress b, Substitutions s) -initWordpress wpconf redis getURI wpLens = do +initCMS :: CMSConfig s + -> R.Connection + -> StateT s IO Text + -> CMSLens b s + -> IO (CMS b, Substitutions s) +initCMS cmsconf redis getURI cmsLens = do let rrunRedis = R.runRedis redis - let logf = wpLogInt $ wpConfLogger wpconf - let wpReq = case wpConfRequester wpconf of + let logf = useLogger $ cmsConfLogger cmsconf + let wpReq = case cmsConfRequest cmsconf of Left (u,p) -> wreqRequester logf u p Right r -> r active <- newMVar Map.empty - let wpInt = WordpressInt{ wpRequest = wpRequestInt wpReq (wpConfEndpoint wpconf) - , wpCacheSet = wpCacheSetInt rrunRedis (wpConfCacheBehavior wpconf) - , wpCacheGet = wpCacheGetInt rrunRedis (wpConfCacheBehavior wpconf) - , startReqMutex = startReqMutexInt active - , stopReqMutex = stopReqMutexInt active - , runRedis = rrunRedis - } - 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 - return (wp, wordpressSubs wp extraFields getURI wpLens) + let cmsInt = CMSInt{ cmsRequest = cmsRequestInt wpReq (cmsConfEndpoint cmsconf) + , cmsCacheSet = cmsCacheSetInt rrunRedis (cmsConfCacheBehavior cmsconf) + , cmsCacheGet = cmsCacheGetInt rrunRedis (cmsConfCacheBehavior cmsconf) + , startReqMutex = startReqMutexInt active + , stopReqMutex = stopReqMutexInt active + , runRedis = rrunRedis + } + let cms = CMS{ requestPostSet = Nothing + , cmsExpireAggregates = wpExpireAggregatesInt rrunRedis + , cmsExpirePost = wpExpirePostInt rrunRedis + , cachingGet = cachingGetInt cmsInt + , cachingGetRetry = cachingGetRetryInt cmsInt + , cachingGetError = cachingGetErrorInt cmsInt + , cacheInternals = cmsInt + , cmsLogger = logf + } + let extraFields = cmsConfExtraFields cmsconf + return (cms, (wordPressSubs <> cmsSubs) cms extraFields getURI cmsLens) diff --git a/src/Web/Offset/Internal.hs b/src/Web/Offset/Internal.hs index 83dd194..18867d3 100644 --- a/src/Web/Offset/Internal.hs +++ b/src/Web/Offset/Internal.hs @@ -17,31 +17,6 @@ import Web.Offset.HTTP import Web.Offset.Types import Web.Offset.Utils -wpRequestInt :: Requester -> Text -> WPKey -> IO (Either StatusCode Text) -wpRequestInt runHTTP endpt key = - case key of - TaxDictKey resName -> req (defaultEndpoint <> "/" <> resName) [] - PostByPermalinkKey _ _ slug -> req (defaultEndpoint <> "/posts") [("slug", slug)] - PostsKey{} -> req (defaultEndpoint <> "/posts") (buildParams key) - PostKey i -> req (defaultEndpoint <> "/posts/" <> tshow i) [] - PageKey s -> req (defaultEndpoint <> "/pages") [("slug", s)] - AuthorKey i -> req (defaultEndpoint <> "/users/" <> tshow i) [] - TaxSlugKey tName tSlug -> req (defaultEndpoint <> "/" <> tName) [("slug", tSlug)] - EndpointKey endpoint -> req ("/" <> endpoint) [] - where req path = unRequester runHTTP (endpt <> path) - defaultEndpoint = "/wp/v2" - -buildParams :: WPKey -> [(Text, Text)] -buildParams (PostsKey filters) = params - where params = Set.toList $ Set.map mkFilter filters - mkFilter (TaxFilter taxonomyName (TaxPlusId i)) = (taxonomyName <> "[]", tshow i) - mkFilter (TaxFilter taxonomyName (TaxMinusId i)) = (taxonomyName <> "_exclude[]", tshow i) - mkFilter (NumFilter num) = ("per_page", tshow num) - mkFilter (OffsetFilter offset) = ("offset", tshow offset) - mkFilter (UserFilter user) = ("author[]", user) -buildParams _ = [] - -wpLogInt :: Maybe (Text -> IO ()) -> Text -> IO () -wpLogInt logger msg = case logger of - Nothing -> return () - Just f -> f msg +cmsRequestInt :: Requester -> Text -> CMSKey -> IO (Either StatusCode Text) +cmsRequestInt runHTTP endpt key = req (cRequestUrl key) + where req (path, params) = unRequester runHTTP (endpt <> path) params diff --git a/src/Web/Offset/Splices.hs b/src/Web/Offset/Splices.hs index 30cf3b9..27fab1d 100644 --- a/src/Web/Offset/Splices.hs +++ b/src/Web/Offset/Splices.hs @@ -13,7 +13,6 @@ import Control.Lens hiding (children) import Control.Concurrent.MVar import Data.Aeson hiding (decode, encode, json, object) import qualified Data.Attoparsec.Text as A -import Data.Char (toUpper) import qualified Data.HashMap.Strict as M import qualified Data.Map as Map import Data.IntSet (IntSet) @@ -28,58 +27,54 @@ import qualified Data.Vector as V import Web.Larceny import Web.Offset.Field -import Web.Offset.Posts -import Web.Offset.Queries import Web.Offset.Types import Web.Offset.Utils - -wordpressSubs :: Wordpress b - -> [Field s] - -> StateT s IO Text - -> WPLens b s - -> Substitutions s -wordpressSubs wp extraFields getURI wpLens = - subs [ ("wpPosts", wpPostsFill wp extraFields wpLens) - , ("wpPostByPermalink", wpPostByPermalinkFill extraFields getURI wpLens) - , ("wpPage", wpPageFill wpLens) - , ("wpNoPostDuplicates", wpNoPostDuplicatesFill wpLens) - , ("wp", wpPrefetch wp extraFields getURI wpLens) - , ("wpCustom", wpCustomFill wp) - , ("wpCustomDate", wpCustomDateFill)] - -wpCustomDateFill :: Fill s -wpCustomDateFill = - useAttrs (a "wp_format" % a "date") customDateFill - where customDateFill mWPFormat date = - let wpFormat = fromMaybe "%Y-%m-%d %H:%M:%S" mWPFormat in - case parseWPDate wpFormat date of - Just d -> fillChildrenWith $ datePartSubs d +import Web.Offset.Splices.Helpers + +cmsSubs :: CMS b + -> [Field s] + -> StateT s IO Text + -> CMSLens b s + -> Substitutions s +cmsSubs wp extraFields getURI cmsLens = + subs [ ("cmsCustom", cmsCustomFill wp) + , ("cmsCustomDate", cmsCustomDateFill)] + +cmsCustomDateFill :: Fill s +cmsCustomDateFill = + useAttrs (a "format" % a "date") customDateFill + where customDateFill mFormat date = + let format = fromMaybe "%Y-%m-%d %H:%M:%S" mFormat in + case parseDate format date of + Just d -> fillChildrenWith $ datePartSubs DefaultPrefix d Nothing -> textFill $ "" -wpCustomFill :: Wordpress b -> Fill s -wpCustomFill Wordpress{..} = +cmsCustomFill :: CMS b -> Fill s +cmsCustomFill CMS{..} = useAttrs (a "endpoint") customFill where customFill endpoint = Fill $ \attrs (path, tpl) lib -> - do let key = EndpointKey endpoint + do let key = CMSKey ("/" <> endpoint, []) + ("endpoint:" <> endpoint) + ("EndpointKey " <> endpoint) res <- liftIO $ cachingGetRetry key case fmap decode res of Left code -> do let notification = "Encountered status code " <> tshow code <> " when querying \"" <> endpoint <> "\"." - liftIO $ wpLogger notification + liftIO $ cmsLogger notification return $ "" Right (Just (json :: Value)) -> unFill (jsonToFill json) attrs (path, tpl) lib Right Nothing -> do let notification = "Unable to decode JSON for endpoint \"" <> endpoint - liftIO $ wpLogger $ notification <> ": " <> tshow res + liftIO $ cmsLogger $ notification <> ": " <> tshow res return $ "" jsonToFill :: Value -> Fill s jsonToFill (Object o) = Fill $ \_ (path, tpl) lib -> runTemplate tpl path objectSubstitutions lib where objectSubstitutions = - subs $ map (\k -> (transformName k, + subs $ map (\k -> (transformName DefaultPrefix k, jsonToFill (fromJust (M.lookup k o)))) (M.keys o) jsonToFill (Array v) = @@ -92,108 +87,26 @@ jsonToFill (Number n) = case floatingOrInteger n of jsonToFill (Bool b) = textFill $ tshow b jsonToFill (Null) = textFill "" - -wpPostsFill :: Wordpress b - -> [Field s] - -> WPLens b s - -> Fill s -wpPostsFill wp extraFields wpLens = Fill $ \attrs tpl lib -> - do let postsQuery = parseQueryNode (Map.toList attrs) - filters <- liftIO $ mkFilters wp (qtaxes postsQuery) - let wpKey = mkWPKey filters postsQuery - res <- liftIO $ cachingGetRetry wp wpKey - case fmap decode res of - Right (Just posts) -> do - let postsW = extractPostIds posts - wp' <- use wpLens - let postsND = take (qlimit postsQuery) - . noDuplicates (requestPostSet wp') $ postsW - addPostIds wpLens (map fst postsND) - unFill (wpPostsHelper extraFields (map snd postsND)) mempty tpl lib - Right Nothing -> return "" - Left code -> do - let notification = "Encountered status code " <> tshow code - <> " when querying wpPosts." - liftIO $ wpLogger wp notification - return $ "" - where noDuplicates :: Maybe IntSet -> [(Int, Object)] -> [(Int, Object)] - noDuplicates Nothing = id - noDuplicates (Just wpPostIdSet) = filter (\(wpId,_) -> IntSet.notMember wpId wpPostIdSet) - -mkFilters :: Wordpress b -> [TaxSpecList] -> IO [Filter] -mkFilters wp specLists = - concat <$> mapM (\(TaxSpecList tName list) -> catMaybes <$> mapM (toFilter tName) list) specLists - where toFilter :: TaxonomyName -> TaxSpec -> IO (Maybe Filter) - toFilter tName tSpec = do - mTSpecId <- lookupSpecId wp tName tSpec - case mTSpecId of - Just tSpecId -> return $ Just (TaxFilter tName tSpecId) - Nothing -> return Nothing - -wpPostsHelper :: [Field s] - -> [Object] - -> Fill s -wpPostsHelper extraFields postsND = mapSubs (postSubs extraFields) postsND - -wpPostByPermalinkFill :: [Field s] - -> StateT s IO Text - -> WPLens b s - -> Fill s -wpPostByPermalinkFill extraFields getURI wpLens = maybeFillChildrenWith' $ - do uri <- getURI - let mperma = parsePermalink uri - case mperma of - Nothing -> return Nothing - Just (year, month, slug) -> - do res <- wpGetPost wpLens (PostByPermalinkKey year month slug) - case res of - Just post -> do addPostIds wpLens [fst (extractPostId post)] - return $ Just (postSubs extraFields post) - _ -> return Nothing - -wpNoPostDuplicatesFill :: WPLens b s -> Fill s -wpNoPostDuplicatesFill wpLens = textFill' $ - do w@Wordpress{..} <- use wpLens - case requestPostSet of - Nothing -> assign wpLens - w{requestPostSet = Just IntSet.empty} - Just _ -> return () - return "" - -wpPageFill :: WPLens b s -> Fill s -wpPageFill wpLens = - useAttrs (a "name") pageFill - where pageFill Nothing = textFill "" - pageFill (Just slug) = textFill' $ - do res <- wpGetPost wpLens (PageKey slug) - return $ case res of - Just page -> case M.lookup "content" page of - Just (Object o) -> case M.lookup "rendered" o of - Just (String r) -> r - _ -> "" - _ -> "" - _ -> "" - -postSubs :: [Field s] -> Object -> Substitutions s -postSubs extra object = subs (map (buildSplice object) (mergeFields postFields extra)) +fieldSubs :: BlankPrefix -> [Field s] -> Object -> Substitutions s +fieldSubs prefix fields object = subs (map (buildSplice object) fields) where buildSplice o (F n) = - (transformName n, textFill $ getText n o) + (transformNameP n, textFill $ getText n o) buildSplice o (P n fill') = - (transformName n, fill' $ getText n o) + (transformNameP n, fill' $ getText n o) buildSplice o (PN n fill') = - (transformName n, fill' (unObj . M.lookup n $ o)) + (transformNameP n, fill' (unObj . M.lookup n $ o)) buildSplice o (PM n fill') = - (transformName n, fill' (unArray . M.lookup n $ o)) + (transformNameP n, fill' (unArray . M.lookup n $ o)) buildSplice o (N n fs) = - (transformName n, fillChildrenWith $ subs + (transformNameP n, fillChildrenWith $ subs (map (buildSplice (unObj . M.lookup n $ o)) fs)) buildSplice o (C n path) = - (transformName n, textFill (getText (last path) . traverseObject (init path) $ o)) + (transformNameP n, textFill (getText (last path) . traverseObject (init path) $ o)) buildSplice o (CN n path fs) = - (transformName n, fillChildrenWith $ subs + (transformNameP n, fillChildrenWith $ subs (map (buildSplice (traverseObject path o)) fs)) buildSplice o (M n fs) = - (transformName n, + (transformNameP n, mapSubs (\oinner -> subs $ map (buildSplice oinner) fs) (unArray . M.lookup n $ o)) @@ -207,137 +120,23 @@ postSubs extra object = subs (map (buildSplice object) (mergeFields postFields e Just (Number i) -> either (tshow :: Double -> Text) (tshow :: Integer -> Text) (floatingOrInteger i) _ -> "" + transformNameP = transformName prefix -- * -- Internal -- * -- -parseQueryNode :: [(Text, Text)] -> WPQuery -parseQueryNode attrs = - mkPostsQuery (readSafe =<< lookup "limit" attrs) - (readSafe =<< lookup "num" attrs) - (readSafe =<< lookup "offset" attrs) - (readSafe =<< lookup "page" attrs) - (filterTaxonomies attrs) - (lookup "user" attrs) - -filterTaxonomies :: [(Text, Text)] -> [TaxSpecList] -filterTaxonomies attrs = - let reservedTerms = ["limit", "num", "offset", "page", "user"] - taxAttrs = filter (\(k, _) -> (k `notElem` reservedTerms)) attrs in - map attrToTaxSpecList taxAttrs - -taxDictKeys :: [TaxSpecList] -> [WPKey] -taxDictKeys = map (\(TaxSpecList tName _) -> TaxDictKey tName) - -mkPostsQuery :: Maybe Int - -> Maybe Int - -> Maybe Int - -> Maybe Int - -> [TaxSpecList] - -> Maybe Text - -> WPQuery -mkPostsQuery l n o p ts us = - WPPostsQuery{ qlimit = fromMaybe 20 l - , qnum = fromMaybe 20 n - , qoffset = fromMaybe 0 o - , qpage = fromMaybe 1 p - , qtaxes = ts - , quser = us - } - -wpPrefetch :: Wordpress b - -> [Field s] - -> StateT s IO Text - -> WPLens b s - -> Fill s -wpPrefetch wp extra uri wpLens = Fill $ \ _m (p, tpl) l -> do - Wordpress{..} <- use wpLens - mKeys <- liftIO $ newMVar [] - void $ runTemplate tpl p (prefetchSubs wp mKeys) l - wpKeys <- liftIO $ readMVar mKeys - void $ liftIO $ concurrently $ map cachingGet wpKeys - runTemplate tpl p (wordpressSubs wp extra uri wpLens) l - -prefetchSubs :: Wordpress b -> MVar [WPKey] -> Substitutions s -prefetchSubs wp mkeys = - subs [ ("wpPosts", wpPostsPrefetch wp mkeys) - , ("wpPage", useAttrs (a"name") $ wpPagePrefetch mkeys) ] - -wpPostsPrefetch :: Wordpress b - -> MVar [WPKey] - -> Fill s -wpPostsPrefetch wp mKeys = Fill $ \attrs _ _ -> - do let postsQuery = parseQueryNode (Map.toList attrs) - filters <- liftIO $ mkFilters wp (qtaxes postsQuery) - let key = mkWPKey filters postsQuery - liftIO $ modifyMVar_ mKeys (\keys -> return $ key : keys) - return "" - -wpPagePrefetch :: MVar [WPKey] - -> Text - -> Fill s -wpPagePrefetch mKeys name = textFill' $ - do let key = PageKey name - liftIO $ modifyMVar_ mKeys (\keys -> return $ key : keys) - return "" - -mkWPKey :: [Filter] - -> WPQuery - -> WPKey -mkWPKey taxFilters WPPostsQuery{..} = - let page = if qpage < 1 then 1 else qpage - offset = qnum * (page - 1) + qoffset - in PostsKey (Set.fromList $ [ NumFilter qnum , OffsetFilter offset] - ++ taxFilters ++ userFilter quser) - where userFilter Nothing = [] - userFilter (Just u) = [UserFilter u] - -findDict :: [(TaxonomyName, TaxSpec -> TaxSpecId)] -> TaxSpecList -> [Filter] -findDict dicts (TaxSpecList tName tList) = - case lookup tName dicts of - Just dict -> map (TaxFilter tName . dict) tList - Nothing -> [] - -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 :: (MonadState s m, MonadIO m) => WPLens b s -> WPKey -> m (Maybe Object) -wpGetPost wpLens wpKey = - do wp <- use wpLens - liftIO $ getPost wp wpKey - -getPost :: Wordpress b -> WPKey -> IO (Maybe Object) -getPost Wordpress{..} wpKey = decodePost <$> cachingGetRetry wpKey - where decodePost :: Either StatusCode Text -> Maybe Object - decodePost (Right t) = - do post' <- decodeJson t - case post' of - Just (post:_) -> Just post +cmsGetSingle :: (MonadState s m, MonadIO m) => CMSLens b s -> CMSKey -> m (Maybe Object) +cmsGetSingle cmsLens wpKey = + do wp <- use cmsLens + liftIO $ getSingle wp wpKey + +getSingle :: CMS b -> CMSKey -> IO (Maybe Object) +getSingle CMS{..} wpKey = decodeObj <$> cachingGetRetry wpKey + where decodeObj :: Either StatusCode Text -> Maybe Object + decodeObj (Right t) = + do obj' <- decodeJson t + case obj' of + Just (obj:_) -> Just obj _ -> Nothing - decodePost (Left _) = 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 :: (MonadState s m, MonadIO m) => WPLens b s -> [Int] -> m () -addPostIds wpLens ids = - do w@Wordpress{..} <- use wpLens - assign wpLens - w{requestPostSet = (`IntSet.union` IntSet.fromList ids) <$> requestPostSet } + decodeObj (Left _) = Nothing {-# ANN module ("HLint: ignore Eta reduce" :: String) #-} diff --git a/src/Web/Offset/Splices/Helpers.hs b/src/Web/Offset/Splices/Helpers.hs new file mode 100644 index 0000000..7bdd019 --- /dev/null +++ b/src/Web/Offset/Splices/Helpers.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module Web.Offset.Splices.Helpers where + +import Control.Arrow (first) +import Data.Aeson (Object) +import Data.Char (toUpper) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (UTCTime) +import Data.Time.Format (defaultTimeLocale, formatTime, parseTimeM) +import Web.Larceny + +import Web.Offset.Types +import Web.Offset.Utils + +datePartSubs :: BlankPrefix -> UTCTime -> Substitutions s +datePartSubs prefix date = + subs $ addPrefixes [ ("year", datePartFill "%0Y" date) + , ("month", datePartFill "%m" date) + , ("day", datePartFill "%d" date) + , ("fullDate", datePartFill "%D" date) ] + where addPrefixes = map (first $ transformName prefix) + datePartFill defaultFormat utcTime = + useAttrs (a "format") $ \mf -> + let f = fromMaybe defaultFormat mf in + textFill $ T.pack $ formatTime defaultTimeLocale (T.unpack f) utcTime + +transformName :: BlankPrefix -> Text -> Text +transformName prefix = T.append (toPrefix prefix) + . 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) diff --git a/src/Web/Offset/Types.hs b/src/Web/Offset/Types.hs index ad65e1b..f23cfe1 100644 --- a/src/Web/Offset/Types.hs +++ b/src/Web/Offset/Types.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ImpredicativeTypes #-} @@ -20,6 +19,7 @@ import Data.List (intercalate) import Data.Maybe (catMaybes, isJust) import Data.Monoid ((<>)) import Data.Set (Set) +import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T @@ -28,131 +28,59 @@ import Web.Offset.Field import Web.Offset.HTTP import Web.Offset.Utils -data Wordpress b = - Wordpress { requestPostSet :: Maybe IntSet - , wpExpireAggregates :: IO Bool - , wpExpirePost :: WPKey -> IO Bool - , cachingGet :: WPKey -> IO (CacheResult Text) - , cachingGetRetry :: WPKey -> IO (Either StatusCode Text) - , cachingGetError :: WPKey -> IO (Either StatusCode Text) - , wpLogger :: Text -> IO () - , cacheInternals :: WordpressInt (StateT b IO Text) - } +data CMS b = + CMS { requestPostSet :: Maybe IntSet + , cmsExpireAggregates :: IO Bool + , cmsExpirePost :: CMSKey -> IO Bool + , cachingGet :: CMSKey -> IO (CacheResult Text) + , cachingGetRetry :: CMSKey -> IO (Either StatusCode Text) + , cachingGetError :: CMSKey -> IO (Either StatusCode Text) + , cmsLogger :: Text -> IO () + , cacheInternals :: CMSInt (StateT b IO Text) + } -type WPLens b s = Lens' s (Wordpress b) +type CMSLens b s = Lens' s (CMS b) type UserPassword = (Text, Text) -data WordpressConfig m = - WordpressConfig { wpConfEndpoint :: Text - , wpConfRequester :: Either UserPassword Requester - , wpConfCacheBehavior :: CacheBehavior - , wpConfExtraFields :: [Field m] - , wpConfLogger :: Maybe (Text -> IO ()) - } - -instance Default (WordpressConfig m) where - def = WordpressConfig "http://127.0.0.1:8080/wp-json" - (Left ("offset", "111")) - (CacheSeconds 600) - [] - Nothing - -data WordpressInt b = - WordpressInt { wpCacheGet :: WPKey -> IO (Maybe Text) - , wpCacheSet :: WPKey -> Text -> IO () - , startReqMutex :: WPKey -> IO Bool - , wpRequest :: WPKey -> IO (Either StatusCode Text) - , stopReqMutex :: WPKey -> IO () - , runRedis :: RunRedis - } - -data TaxSpec = TaxPlus Text | TaxMinus Text deriving (Eq, Ord) - -data TaxSpecId = TaxPlusId Int | TaxMinusId Int deriving (Eq, Show, Ord) - -data CatType -data TagType -type CustomType = Text - -instance Show TaxSpec where - show (TaxPlus t) = '+' : T.unpack t - show (TaxMinus t) = '-' : T.unpack t - -newtype TaxRes = TaxRes (Int, Text) deriving (Show) - -instance FromJSON TaxRes where - parseJSON (Object o) = TaxRes <$> ((,) <$> o .: "id" <*> o .: "slug") - parseJSON _ = mzero - -data TaxDict = TaxDict { dict :: [TaxRes] - , desc :: Text} deriving (Show) - -type Year = Text -type Month = Text -type Slug = Text -type TaxonomyName = Text - -data Filter = TaxFilter TaxonomyName TaxSpecId - | NumFilter Int - | OffsetFilter Int - | UserFilter Text - deriving (Eq, Ord) - -instance Show Filter where - show (TaxFilter n t) = show n ++ "_" ++ show t - show (NumFilter n) = "num_" ++ show n - show (OffsetFilter n) = "offset_" ++ show n - show (UserFilter u) = T.unpack $ "user_" <> u - -data WPKey = PostKey Int - | PostByPermalinkKey Year Month Slug - | PostsKey (Set Filter) - | PageKey Text - | AuthorKey Int - | TaxDictKey Text - | TaxSlugKey TaxonomyName Slug - | EndpointKey Text - deriving (Eq, Show, Ord) - -tagChars :: String -tagChars = ['a'..'z'] ++ "-" ++ digitChars - -digitChars :: String -digitChars = ['0'..'9'] - -instance Read TaxSpec 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 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 _ _ = [] - -data TaxSpecList = TaxSpecList { taxName :: TaxonomyName - , taxList :: [TaxSpec]} deriving (Eq, Ord) - -instance Show TaxSpecList where - show (TaxSpecList n ts) = T.unpack n ++ ": " ++ intercalate "," (map show ts) - -attrToTaxSpecList :: (Text, Text) -> TaxSpecList -attrToTaxSpecList (k, ts) = - let vs = map readSafe $ T.splitOn "," ts in - if all isJust vs - then TaxSpecList k (catMaybes vs) - else TaxSpecList k [] +data CMSConfig m = + CMSConfig { cmsConfEndpoint :: Text + , cmsConfRequest :: Either UserPassword Requester + , cmsConfCacheBehavior :: CacheBehavior + , cmsConfExtraFields :: [Field m] + , cmsConfLogger :: Maybe (Text -> IO ()) + } -data WPQuery = WPPostsQuery{ qlimit :: Int - , qnum :: Int - , qoffset :: Int - , qpage :: Int - , qtaxes :: [TaxSpecList] - , quser :: Maybe Text - } deriving (Show) +instance Default (CMSConfig m) where + def = CMSConfig "http://127.0.0.1:8080/wp-json" + (Left ("offset", "111")) + (CacheSeconds 600) + [] + Nothing + +data CMSInt b = + CMSInt { cmsCacheGet :: CMSKey -> IO (Maybe Text) + , cmsCacheSet :: CMSKey -> Text -> IO () + , startReqMutex :: CMSKey -> IO Bool + , cmsRequest :: CMSKey -> IO (Either StatusCode Text) + , stopReqMutex :: CMSKey -> IO () + , runRedis :: RunRedis + } + +data BlankPrefix = DefaultPrefix | Prefix Text + +toPrefix :: BlankPrefix -> Text +toPrefix DefaultPrefix = "cms" +toPrefix (Prefix p) = p + +data CMSKey = CMSKey { cRequestUrl :: (Text, [(Text, Text)]) + , cFormatKey :: Text + , cShow :: Text } + +instance Ord CMSKey where + compare key1 key2 = compare (cShow key1) (cShow key2) +instance Eq CMSKey where + key1 == key2 = cShow key1 == cShow key2 type StatusCode = Int diff --git a/src/Web/Offset/Utils.hs b/src/Web/Offset/Utils.hs index 9ff38f4..4695891 100644 --- a/src/Web/Offset/Utils.hs +++ b/src/Web/Offset/Utils.hs @@ -11,6 +11,9 @@ 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 Data.Time.Clock (UTCTime) +import Data.Time.Format (defaultTimeLocale, formatTime, + parseTimeM) readSafe :: Read a => Text -> Maybe a readSafe = fmap fst . listToMaybe . reads . T.unpack @@ -45,3 +48,15 @@ concurrently [a] = concurrently (a:as) = do (r1, rs) <- CC.concurrently a (concurrently as) return (r1:rs) + +parseDate :: Text -> Text -> Maybe UTCTime +parseDate format date = + parseTimeM False + defaultTimeLocale + (T.unpack format) + (T.unpack date) :: Maybe UTCTime + +useLogger :: Maybe (Text -> IO ()) -> Text -> IO () +useLogger logger msg = case logger of + Nothing -> return () + Just f -> f msg diff --git a/src/Web/Offset/WordPress/Field.hs b/src/Web/Offset/WordPress/Field.hs new file mode 100644 index 0000000..9dd797f --- /dev/null +++ b/src/Web/Offset/WordPress/Field.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module Web.Offset.WordPress.Field where + +import Data.Aeson (Object) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (UTCTime) +import Data.Time.Format (defaultTimeLocale, formatTime, + parseTimeM) +import Web.Larceny + +import Web.Offset.Field +import Web.Offset.Splices.Helpers +import Web.Offset.Types +import Web.Offset.Utils + +postFields :: [Field s] +postFields = [F "id" + ,C "title" ["title", "rendered"] + ,F "status" + ,F "type" + ,F "author" + ,C "content" ["content", "rendered"] + ,P "date" wpDateFill + ,F "slug" + ,C "excerpt" ["excerpt", "rendered"] + ,N "custom_fields" [F "test"] + ,N "featured_media" [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"]] + ] + +wpDateFill :: Text -> Fill s +wpDateFill date = + let wpFormat = "%Y-%m-%dT%H:%M:%S" in + case parseDate wpFormat date of + Just d -> fillChildrenWith $ datePartSubs (Prefix "wp") d + Nothing -> textFill $ "" diff --git a/src/Web/Offset/Posts.hs b/src/Web/Offset/WordPress/Posts.hs similarity index 96% rename from src/Web/Offset/Posts.hs rename to src/Web/Offset/WordPress/Posts.hs index fb4f76d..69477aa 100644 --- a/src/Web/Offset/Posts.hs +++ b/src/Web/Offset/WordPress/Posts.hs @@ -6,7 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} -module Web.Offset.Posts where +module Web.Offset.WordPress.Posts where import Data.Aeson import qualified Data.HashMap.Strict as M diff --git a/src/Web/Offset/Queries.hs b/src/Web/Offset/WordPress/Queries.hs similarity index 67% rename from src/Web/Offset/Queries.hs rename to src/Web/Offset/WordPress/Queries.hs index 69fdb30..768918e 100644 --- a/src/Web/Offset/Queries.hs +++ b/src/Web/Offset/WordPress/Queries.hs @@ -1,15 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -module Web.Offset.Queries where +module Web.Offset.WordPress.Queries where import Data.Monoid -import Data.Text (Text) +import Data.Text (Text) import Web.Offset.Cache import Web.Offset.Cache.Types import Web.Offset.Types import Web.Offset.Utils +import Web.Offset.WordPress.Types getSpecId :: TaxDict -> TaxSpec -> TaxSpecId getSpecId taxDict spec = @@ -23,8 +24,8 @@ getSpecId taxDict spec = [] -> terror $ "Couldn't find " <> desc <> ": " <> slug (TaxRes (i,_):_) -> i -lookupSpecId :: Wordpress b -> TaxonomyName -> TaxSpec -> IO (Maybe TaxSpecId) -lookupSpecId Wordpress{..} taxName spec = +lookupSpecId :: CMS b -> TaxonomyName -> TaxSpec -> IO (Maybe TaxSpecId) +lookupSpecId CMS{..} taxName spec = case spec of TaxPlus slug -> (fmap . fmap) (\(TaxRes (i, _)) -> TaxPlusId i) (idFor taxName slug) TaxMinus slug -> (fmap . fmap) (\(TaxRes (i, _)) -> TaxMinusId i) (idFor taxName slug) @@ -32,22 +33,22 @@ lookupSpecId Wordpress{..} taxName spec = idFor :: Text -> Text -> IO (Maybe TaxRes) idFor _ slug = do let key = TaxSlugKey taxName slug - let cacheSettings = cacheInternals { wpCacheSet = wpCacheSetInt (runRedis cacheInternals) + let cacheSettings = cacheInternals { cmsCacheSet = cmsCacheSetInt (runRedis cacheInternals) (CacheSeconds (12 * 60 * 60)) } - resp <- cachingGetErrorInt cacheSettings key + resp <- cachingGetErrorInt cacheSettings (toCMSKey key) case fmap decodeJson resp of Left errCode -> do - wpLogger $ "Cache lookup returned HTTP error code " <> tshow errCode + cmsLogger $ "Cache lookup returned HTTP error code " <> tshow errCode return Nothing Right Nothing -> do - wpLogger $ "Unparseable JSON in lookupSpecId for: " <> tshow spec <> + cmsLogger $ "Unparseable JSON in lookupSpecId for: " <> tshow spec <> " response: " <> tshow resp return Nothing Right (Just []) -> do - wpLogger $ "No id found in lookupSpecId for: " <> tshow spec + cmsLogger $ "No id found in lookupSpecId for: " <> tshow spec return Nothing Right (Just [taxRes]) -> return $ Just taxRes Right (Just (_:_)) -> do - wpLogger $ "JSON response in lookupSpecId for: " <> tshow spec + cmsLogger $ "JSON response in lookupSpecId for: " <> tshow spec <> " contains multiple results: " <> tshow resp return Nothing diff --git a/src/Web/Offset/WordPress/Splices.hs b/src/Web/Offset/WordPress/Splices.hs new file mode 100644 index 0000000..5fcde4b --- /dev/null +++ b/src/Web/Offset/WordPress/Splices.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Web.Offset.WordPress.Splices where + +import Control.Monad.State +import Control.Applicative ((<|>)) +import Control.Lens hiding (children) +import Control.Concurrent.MVar +import Data.Aeson hiding (decode, encode, json, object) +import qualified Data.Attoparsec.Text as A +import Data.Char (toUpper) +import qualified Data.HashMap.Strict as M +import qualified Data.Map as Map +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import Data.Maybe (fromJust, fromMaybe, catMaybes) +import Data.Monoid +import Data.Scientific (floatingOrInteger) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import Web.Larceny + +import Web.Offset.Field +import Web.Offset.WordPress.Posts +import Web.Offset.WordPress.Queries +import Web.Offset.Types +import Web.Offset.WordPress.Types +import Web.Offset.Utils +import Web.Offset.Splices +import Web.Offset.WordPress.Field + +wordPressSubs :: CMS b + -> [Field s] + -> StateT s IO Text + -> CMSLens b s + -> Substitutions s +wordPressSubs wp extraFields getURI cmsLens = + subs [ ("wpPosts", wpPostsFill wp extraFields cmsLens) + , ("wpPostByPermalink", wpPostByPermalinkFill extraFields getURI cmsLens) + , ("wpPage", wpPageFill cmsLens) + , ("wpNoPostDuplicates", wpNoPostDuplicatesFill cmsLens) + , ("wp", wpPrefetch wp extraFields getURI cmsLens)] + +wpFieldSubs :: [Field s] -> Object -> Substitutions s +wpFieldSubs extraFields = fieldSubs (Prefix "wp") (mergeFields postFields extraFields) + +wpPostsFill :: CMS b + -> [Field s] + -> CMSLens b s + -> Fill s +wpPostsFill wp extraFields cmsLens = Fill $ \attrs tpl lib -> + do let postsQuery = parseQueryNode (Map.toList attrs) + filters <- liftIO $ mkFilters wp (qtaxes postsQuery) + let wpKey = mkWPKey filters postsQuery + res <- liftIO $ cachingGetRetry wp (toCMSKey wpKey) + case fmap decode res of + Right (Just posts) -> do + let postsW = extractPostIds posts + wp' <- use cmsLens + let postsND = take (qlimit postsQuery) + . noDuplicates (requestPostSet wp') $ postsW + addPostIds cmsLens (map fst postsND) + unFill (wpPostsHelper extraFields (map snd postsND)) mempty tpl lib + Right Nothing -> return "" + Left code -> do + let notification = "Encountered status code " <> tshow code + <> " when querying wpPosts." + liftIO $ cmsLogger wp notification + return $ "" + where noDuplicates :: Maybe IntSet -> [(Int, Object)] -> [(Int, Object)] + noDuplicates Nothing = id + noDuplicates (Just wpPostIdSet) = filter (\(wpId,_) -> IntSet.notMember wpId wpPostIdSet) + +mkFilters :: CMS b -> [TaxSpecList] -> IO [Filter] +mkFilters wp specLists = + concat <$> mapM (\(TaxSpecList tName list) -> catMaybes <$> mapM (toFilter tName) list) specLists + where toFilter :: TaxonomyName -> TaxSpec -> IO (Maybe Filter) + toFilter tName tSpec = do + mTSpecId <- lookupSpecId wp tName tSpec + case mTSpecId of + Just tSpecId -> return $ Just (TaxFilter tName tSpecId) + Nothing -> return Nothing + +wpPostsHelper :: [Field s] + -> [Object] + -> Fill s +wpPostsHelper extraFields postsND = mapSubs (wpFieldSubs extraFields) postsND + +wpPostByPermalinkFill :: [Field s] + -> StateT s IO Text + -> CMSLens b s + -> Fill s +wpPostByPermalinkFill extraFields getURI cmsLens = maybeFillChildrenWith' $ + do uri <- getURI + let mperma = parsePermalink uri + case mperma of + Nothing -> return Nothing + Just (year, month, slug) -> + do res <- cmsGetSingle cmsLens (toCMSKey $ PostByPermalinkKey year month slug) + case res of + Just post -> do addPostIds cmsLens [fst (extractPostId post)] + return $ Just (wpFieldSubs extraFields post) + _ -> return Nothing + +wpNoPostDuplicatesFill :: CMSLens b s -> Fill s +wpNoPostDuplicatesFill cmsLens = textFill' $ + do w@CMS{..} <- use cmsLens + case requestPostSet of + Nothing -> assign cmsLens + w{requestPostSet = Just IntSet.empty} + Just _ -> return () + return "" + +wpPageFill :: CMSLens b s -> Fill s +wpPageFill cmsLens = + useAttrs (a "name") pageFill + where pageFill Nothing = textFill "" + pageFill (Just slug) = textFill' $ + do res <- cmsGetSingle cmsLens (toCMSKey $ PageKey slug) + return $ case res of + Just page -> case M.lookup "content" page of + Just (Object o) -> case M.lookup "rendered" o of + Just (String r) -> r + _ -> "" + _ -> "" + _ -> "" + +-- * -- Internal -- * -- + +parseQueryNode :: [(Text, Text)] -> WPQuery +parseQueryNode attrs = + mkPostsQuery (readSafe =<< lookup "limit" attrs) + (readSafe =<< lookup "num" attrs) + (readSafe =<< lookup "offset" attrs) + (readSafe =<< lookup "page" attrs) + (filterTaxonomies attrs) + (lookup "user" attrs) + +filterTaxonomies :: [(Text, Text)] -> [TaxSpecList] +filterTaxonomies attrs = + let reservedTerms = ["limit", "num", "offset", "page", "user"] + taxAttrs = filter (\(k, _) -> (k `notElem` reservedTerms)) attrs in + map attrToTaxSpecList taxAttrs + +taxDictKeys :: [TaxSpecList] -> [CMSKey] +taxDictKeys = map (\(TaxSpecList tName _) -> toCMSKey $ TaxDictKey tName) + +mkPostsQuery :: Maybe Int + -> Maybe Int + -> Maybe Int + -> Maybe Int + -> [TaxSpecList] + -> Maybe Text + -> WPQuery +mkPostsQuery l n o p ts us = + WPPostsQuery{ qlimit = fromMaybe 20 l + , qnum = fromMaybe 20 n + , qoffset = fromMaybe 0 o + , qpage = fromMaybe 1 p + , qtaxes = ts + , quser = us + } + +wpPrefetch :: CMS b + -> [Field s] + -> StateT s IO Text + -> CMSLens b s + -> Fill s +wpPrefetch wp extra uri cmsLens = Fill $ \ _m (p, tpl) l -> do + CMS{..} <- use cmsLens + mKeys <- liftIO $ newMVar [] + void $ runTemplate tpl p (prefetchSubs wp mKeys) l + wpKeys <- liftIO $ readMVar mKeys + void $ liftIO $ concurrently $ map cachingGet (map toCMSKey wpKeys) + runTemplate tpl p (wordPressSubs wp extra uri cmsLens) l + +prefetchSubs :: CMS b -> MVar [WPKey] -> Substitutions s +prefetchSubs wp mkeys = + subs [ ("wpPosts", wpPostsPrefetch wp mkeys) + , ("wpPage", useAttrs (a"name") $ wpPagePrefetch mkeys) ] + +wpPostsPrefetch :: CMS b + -> MVar [WPKey] + -> Fill s +wpPostsPrefetch wp mKeys = Fill $ \attrs _ _ -> + do let postsQuery = parseQueryNode (Map.toList attrs) + filters <- liftIO $ mkFilters wp (qtaxes postsQuery) + let key = mkWPKey filters postsQuery + liftIO $ modifyMVar_ mKeys (\keys -> return $ key : keys) + return "" + +wpPagePrefetch :: MVar [WPKey] + -> Text + -> Fill s +wpPagePrefetch mKeys name = textFill' $ + do let key = PageKey name + liftIO $ modifyMVar_ mKeys (\keys -> return $ key : keys) + return "" + +mkWPKey :: [Filter] + -> WPQuery + -> WPKey +mkWPKey taxFilters WPPostsQuery{..} = + let page = if qpage < 1 then 1 else qpage + offset = qnum * (page - 1) + qoffset + in PostsKey (Set.fromList $ [ NumFilter qnum , OffsetFilter offset] + ++ taxFilters ++ userFilter quser) + where userFilter Nothing = [] + userFilter (Just u) = [UserFilter u] + +findDict :: [(TaxonomyName, TaxSpec -> TaxSpecId)] -> TaxSpecList -> [Filter] +findDict dicts (TaxSpecList tName tList) = + case lookup tName dicts of + Just dict -> map (TaxFilter tName . dict) tList + Nothing -> [] + +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) + +addPostIds :: (MonadState s m, MonadIO m) => CMSLens b s -> [Int] -> m () +addPostIds cmsLens ids = + do cms@CMS{..} <- use cmsLens + assign cmsLens + cms{requestPostSet = (`IntSet.union` IntSet.fromList ids) <$> requestPostSet } + +{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} diff --git a/src/Web/Offset/WordPress/Types.hs b/src/Web/Offset/WordPress/Types.hs new file mode 100644 index 0000000..1c8a787 --- /dev/null +++ b/src/Web/Offset/WordPress/Types.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Web.Offset.WordPress.Types where + +import Control.Lens hiding (children) +import Control.Monad.State +import Data.Aeson (FromJSON, Value (..), parseJSON, (.:)) +import Data.Default +import Data.IntSet (IntSet) +import Data.List (intercalate) +import Data.Maybe (catMaybes, isJust) +import Data.Monoid ((<>)) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T + +import Web.Offset.Cache.Types +import Web.Offset.Field +import Web.Offset.HTTP +import Web.Offset.Types +import Web.Offset.Utils + +data TaxSpec = TaxPlus Text | TaxMinus Text deriving (Eq, Ord) + +data TaxSpecId = TaxPlusId Int | TaxMinusId Int deriving (Eq, Show, Ord) + +instance Show TaxSpec where + show (TaxPlus t) = '+' : T.unpack t + show (TaxMinus t) = '-' : T.unpack t + +newtype TaxRes = TaxRes (Int, Text) deriving (Show) + +instance FromJSON TaxRes where + parseJSON (Object o) = TaxRes <$> ((,) <$> o .: "id" <*> o .: "slug") + parseJSON _ = mzero + +data TaxDict = TaxDict { dict :: [TaxRes] + , desc :: Text} deriving (Show) + +type Year = Text +type Month = Text +type Slug = Text +type TaxonomyName = Text + +data Filter = TaxFilter TaxonomyName TaxSpecId + | NumFilter Int + | OffsetFilter Int + | UserFilter Text + deriving (Eq, Ord) + +instance Show Filter where + show (TaxFilter n t) = show n ++ "_" ++ show t + show (NumFilter n) = "num_" ++ show n + show (OffsetFilter n) = "offset_" ++ show n + show (UserFilter u) = T.unpack $ "user_" <> u + +data WPKey = PostKey Int + | PostByPermalinkKey Year Month Slug + | PostsKey (Set Filter) + | PageKey Text + | AuthorKey Int + | TaxDictKey Text + | TaxSlugKey TaxonomyName Slug + deriving (Eq, Show, Ord) + +toCMSKey :: WPKey -> CMSKey +toCMSKey wpKey = + case wpKey of + PostKey i -> + CMSKey ("/wp/v2/posts/" <> tshow i, []) + (ns "post:" <> tshow i) + (tshow wpKey) + PostByPermalinkKey y m s -> + CMSKey ("/wp/v2/posts", [("slug", s)]) + (ns "post_perma:" <> y <> "_" <> m <> "_" <> s) + (tshow wpKey) + PostsKey filters -> + CMSKey ("/wp/v2/posts", buildParams' filters) + (ns "posts:" <> T.intercalate "_" + (map tshow $ Set.toAscList filters)) + (tshow wpKey) + PageKey slug -> + CMSKey ("/wp/v2/pages", [("slug", slug)]) + (ns "page:" <> slug) + (tshow wpKey) + AuthorKey i -> + CMSKey ("/wp/v2/users/" <> tshow i, []) + (ns "author:" <> tshow i) + (tshow wpKey) + TaxDictKey resName -> + CMSKey ("/wp/v2/" <> resName, []) + (ns "tax_dict:" <> resName) + (tshow wpKey) + TaxSlugKey tn slug -> + CMSKey ("/wp/v2/" <> tn, [("slug", slug)]) + (ns "tax_slug:" <> tn <> ":" <> slug) + (tshow wpKey) + where ns k = "wordpress:" <> k + +buildParams' :: Set.Set Filter -> [(Text, Text)] +buildParams' filters = params + where params = Set.toList $ Set.map mkFilter filters + mkFilter (TaxFilter taxonomyName (TaxPlusId i)) = (taxonomyName <> "[]", tshow i) + mkFilter (TaxFilter taxonomyName (TaxMinusId i)) = (taxonomyName <> "_exclude[]", tshow i) + mkFilter (NumFilter num) = ("per_page", tshow num) + mkFilter (OffsetFilter offset) = ("offset", tshow offset) + mkFilter (UserFilter user) = ("author[]", user) + +tagChars :: String +tagChars = ['a'..'z'] ++ "-" ++ digitChars + +digitChars :: String +digitChars = ['0'..'9'] + +instance Read TaxSpec 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 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 _ _ = [] + +data TaxSpecList = TaxSpecList { taxName :: TaxonomyName + , taxList :: [TaxSpec]} deriving (Eq, Ord) + +instance Show TaxSpecList where + show (TaxSpecList n ts) = T.unpack n ++ ": " ++ intercalate "," (map show ts) + +attrToTaxSpecList :: (Text, Text) -> TaxSpecList +attrToTaxSpecList (k, ts) = + let vs = map readSafe $ T.splitOn "," ts in + if all isJust vs + then TaxSpecList k (catMaybes vs) + else TaxSpecList k [] + +data WPQuery = WPPostsQuery{ qlimit :: Int + , qnum :: Int + , qoffset :: Int + , qpage :: Int + , qtaxes :: [TaxSpecList] + , quser :: Maybe Text + } deriving (Show)