From cd1e1641968a1514f14f746927ceb3f9eae82ac8 Mon Sep 17 00:00:00 2001 From: Libby Horacek Date: Sat, 4 Mar 2017 00:09:41 -0500 Subject: [PATCH 01/11] Replace references to WordPress with CMS --- spec/Common.hs | 66 +++++++++++----------- spec/Main.hs | 46 +++++++-------- src/Web/Offset.hs | 8 +-- src/Web/Offset/Cache.hs | 34 ++++++------ src/Web/Offset/Init.hs | 52 ++++++++--------- src/Web/Offset/Internal.hs | 14 ++--- src/Web/Offset/Queries.hs | 14 ++--- src/Web/Offset/Splices.hs | 111 ++++++++++++++++++------------------- src/Web/Offset/Types.hs | 88 ++++++++++++++--------------- 9 files changed, 216 insertions(+), 217 deletions(-) diff --git a/spec/Common.hs b/spec/Common.hs index bba7b91..b8b5376 100644 --- a/spec/Common.hs +++ b/spec/Common.hs @@ -38,11 +38,11 @@ import Web.Offset.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 @@ -131,7 +131,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 +170,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 +218,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 -> CMSKey -> m (Maybe Text) +cmsCacheGet' cms' wpKey = do + let CMSInt{..} = cacheInternals cms' + liftIO $ cmsCacheGet 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 -> CMSKey -> Text -> m () +cmsCacheSet' cms' wpKey o = do + let CMSInt{..} = cacheInternals cms' + liftIO $ cmsCacheSet 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 -> CMSKey -> m Bool +cmsExpirePost' CMS{..} k = + liftIO $ cmsExpirePost k {- shouldRenderAtUrlContaining' :: (TemplateName, Ctxt) @@ -250,7 +250,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 +263,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..6edf137 100644 --- a/spec/Main.hs +++ b/spec/Main.hs @@ -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" @@ -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/src/Web/Offset.hs b/src/Web/Offset.hs index d88e475..fa52ee7 100644 --- a/src/Web/Offset.hs +++ b/src/Web/Offset.hs @@ -9,14 +9,14 @@ {-# LANGUAGE TypeSynonymInstances #-} module Web.Offset ( - Wordpress(..) - , WordpressConfig(..) + CMS(..) + , CMSConfig(..) , Requester(..) , CacheBehavior(..) - , initWordpress + , initCMS , wpGetPost , getPost - , WPKey(..) + , CMSKey(..) , Filter(..) , transformName , TaxSpec(..) diff --git a/src/Web/Offset/Cache.hs b/src/Web/Offset/Cache.hs index 2397005..d1a5079 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,14 +30,14 @@ 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 @@ -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 . 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) +cmsCacheSetInt :: RunRedis -> CacheBehavior -> CMSKey -> Text -> IO () +cmsCacheSetInt runRedis b key = void . runRedis . cacheSet b (formatKey key) cacheSet :: CacheBehavior -> Text -> Text -> Redis Bool cacheSet b k v = @@ -102,13 +102,13 @@ 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 :: CMSKey -> Redis Bool expire key = rdel [formatKey key] >> expireAggregates -formatKey :: WPKey -> Text +formatKey :: CMSKey -> Text formatKey = format where format (PostByPermalinkKey y m s) = ns "post_perma:" <> y <> "_" <> m <> "_" <> s format (PostsKey filters) = diff --git a/src/Web/Offset/Init.hs b/src/Web/Offset/Init.hs index 3f9a46f..a73cf23 100644 --- a/src/Web/Offset/Init.hs +++ b/src/Web/Offset/Init.hs @@ -16,33 +16,33 @@ import Web.Offset.Internal import Web.Offset.Splices import Web.Offset.Types -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 = cmsLogInt $ 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 cms extraFields getURI cmsLens) diff --git a/src/Web/Offset/Internal.hs b/src/Web/Offset/Internal.hs index 83dd194..e39e069 100644 --- a/src/Web/Offset/Internal.hs +++ b/src/Web/Offset/Internal.hs @@ -17,8 +17,8 @@ import Web.Offset.HTTP import Web.Offset.Types import Web.Offset.Utils -wpRequestInt :: Requester -> Text -> WPKey -> IO (Either StatusCode Text) -wpRequestInt runHTTP endpt key = +cmsRequestInt :: Requester -> Text -> CMSKey -> IO (Either StatusCode Text) +cmsRequestInt runHTTP endpt key = case key of TaxDictKey resName -> req (defaultEndpoint <> "/" <> resName) [] PostByPermalinkKey _ _ slug -> req (defaultEndpoint <> "/posts") [("slug", slug)] @@ -31,7 +31,7 @@ wpRequestInt runHTTP endpt key = where req path = unRequester runHTTP (endpt <> path) defaultEndpoint = "/wp/v2" -buildParams :: WPKey -> [(Text, Text)] +buildParams :: CMSKey -> [(Text, Text)] buildParams (PostsKey filters) = params where params = Set.toList $ Set.map mkFilter filters mkFilter (TaxFilter taxonomyName (TaxPlusId i)) = (taxonomyName <> "[]", tshow i) @@ -41,7 +41,7 @@ buildParams (PostsKey filters) = params mkFilter (UserFilter user) = ("author[]", user) buildParams _ = [] -wpLogInt :: Maybe (Text -> IO ()) -> Text -> IO () -wpLogInt logger msg = case logger of - Nothing -> return () - Just f -> f msg +cmsLogInt :: Maybe (Text -> IO ()) -> Text -> IO () +cmsLogInt logger msg = case logger of + Nothing -> return () + Just f -> f msg diff --git a/src/Web/Offset/Queries.hs b/src/Web/Offset/Queries.hs index 69fdb30..013ae69 100644 --- a/src/Web/Offset/Queries.hs +++ b/src/Web/Offset/Queries.hs @@ -23,8 +23,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 +32,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 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/Splices.hs b/src/Web/Offset/Splices.hs index 30cf3b9..d1d204c 100644 --- a/src/Web/Offset/Splices.hs +++ b/src/Web/Offset/Splices.hs @@ -33,17 +33,17 @@ import Web.Offset.Queries import Web.Offset.Types import Web.Offset.Utils -wordpressSubs :: Wordpress b +wordpressSubs :: CMS b -> [Field s] -> StateT s IO Text - -> WPLens b s + -> CMSLens 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) +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) , ("wpCustom", wpCustomFill wp) , ("wpCustomDate", wpCustomDateFill)] @@ -56,8 +56,8 @@ wpCustomDateFill = Just d -> fillChildrenWith $ datePartSubs d Nothing -> textFill $ "" -wpCustomFill :: Wordpress b -> Fill s -wpCustomFill Wordpress{..} = +wpCustomFill :: CMS b -> Fill s +wpCustomFill CMS{..} = useAttrs (a "endpoint") customFill where customFill endpoint = Fill $ \attrs (path, tpl) lib -> do let key = EndpointKey endpoint @@ -66,13 +66,13 @@ wpCustomFill Wordpress{..} = 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 @@ -93,34 +93,34 @@ jsonToFill (Bool b) = textFill $ tshow b jsonToFill (Null) = textFill "" -wpPostsFill :: Wordpress b +wpPostsFill :: CMS b -> [Field s] - -> WPLens b s + -> CMSLens b s -> Fill s -wpPostsFill wp extraFields wpLens = Fill $ \attrs tpl lib -> +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 + let wpKey = mkCMSKey filters postsQuery res <- liftIO $ cachingGetRetry wp wpKey case fmap decode res of Right (Just posts) -> do let postsW = extractPostIds posts - wp' <- use wpLens + wp' <- use cmsLens let postsND = take (qlimit postsQuery) . noDuplicates (requestPostSet wp') $ postsW - addPostIds wpLens (map fst postsND) + 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 $ wpLogger wp notification + 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 :: Wordpress b -> [TaxSpecList] -> IO [Filter] +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) @@ -137,35 +137,35 @@ wpPostsHelper extraFields postsND = mapSubs (postSubs extraFields) postsND wpPostByPermalinkFill :: [Field s] -> StateT s IO Text - -> WPLens b s + -> CMSLens b s -> Fill s -wpPostByPermalinkFill extraFields getURI wpLens = maybeFillChildrenWith' $ +wpPostByPermalinkFill extraFields getURI cmsLens = 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) + do res <- wpGetPost cmsLens (PostByPermalinkKey year month slug) case res of - Just post -> do addPostIds wpLens [fst (extractPostId post)] + Just post -> do addPostIds cmsLens [fst (extractPostId post)] return $ Just (postSubs extraFields post) _ -> return Nothing -wpNoPostDuplicatesFill :: WPLens b s -> Fill s -wpNoPostDuplicatesFill wpLens = textFill' $ - do w@Wordpress{..} <- use wpLens +wpNoPostDuplicatesFill :: CMSLens b s -> Fill s +wpNoPostDuplicatesFill cmsLens = textFill' $ + do w@CMS{..} <- use cmsLens case requestPostSet of - Nothing -> assign wpLens + Nothing -> assign cmsLens w{requestPostSet = Just IntSet.empty} Just _ -> return () return "" -wpPageFill :: WPLens b s -> Fill s -wpPageFill wpLens = +wpPageFill :: CMSLens b s -> Fill s +wpPageFill cmsLens = useAttrs (a "name") pageFill where pageFill Nothing = textFill "" pageFill (Just slug) = textFill' $ - do res <- wpGetPost wpLens (PageKey slug) + do res <- wpGetPost cmsLens (PageKey slug) return $ case res of Just page -> case M.lookup "content" page of Just (Object o) -> case M.lookup "rendered" o of @@ -225,7 +225,7 @@ filterTaxonomies attrs = taxAttrs = filter (\(k, _) -> (k `notElem` reservedTerms)) attrs in map attrToTaxSpecList taxAttrs -taxDictKeys :: [TaxSpecList] -> [WPKey] +taxDictKeys :: [TaxSpecList] -> [CMSKey] taxDictKeys = map (\(TaxSpecList tName _) -> TaxDictKey tName) mkPostsQuery :: Maybe Int @@ -244,35 +244,35 @@ mkPostsQuery l n o p ts us = , quser = us } -wpPrefetch :: Wordpress b +wpPrefetch :: CMS b -> [Field s] -> StateT s IO Text - -> WPLens b s + -> CMSLens b s -> Fill s -wpPrefetch wp extra uri wpLens = Fill $ \ _m (p, tpl) l -> do - Wordpress{..} <- use wpLens +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 wpKeys - runTemplate tpl p (wordpressSubs wp extra uri wpLens) l + runTemplate tpl p (wordpressSubs wp extra uri cmsLens) l -prefetchSubs :: Wordpress b -> MVar [WPKey] -> Substitutions s +prefetchSubs :: CMS b -> MVar [CMSKey] -> Substitutions s prefetchSubs wp mkeys = subs [ ("wpPosts", wpPostsPrefetch wp mkeys) , ("wpPage", useAttrs (a"name") $ wpPagePrefetch mkeys) ] -wpPostsPrefetch :: Wordpress b - -> MVar [WPKey] +wpPostsPrefetch :: CMS b + -> MVar [CMSKey] -> 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 + let key = mkCMSKey filters postsQuery liftIO $ modifyMVar_ mKeys (\keys -> return $ key : keys) return "" -wpPagePrefetch :: MVar [WPKey] +wpPagePrefetch :: MVar [CMSKey] -> Text -> Fill s wpPagePrefetch mKeys name = textFill' $ @@ -280,10 +280,10 @@ wpPagePrefetch mKeys name = textFill' $ liftIO $ modifyMVar_ mKeys (\keys -> return $ key : keys) return "" -mkWPKey :: [Filter] +mkCMSKey :: [Filter] -> WPQuery - -> WPKey -mkWPKey taxFilters WPPostsQuery{..} = + -> CMSKey +mkCMSKey taxFilters WPPostsQuery{..} = let page = if qpage < 1 then 1 else qpage offset = qnum * (page - 1) + qoffset in PostsKey (Set.fromList $ [ NumFilter qnum , OffsetFilter offset] @@ -310,13 +310,13 @@ parsePermalink = either (const Nothing) Just . A.parseOnly parser . T.reverse ,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 +wpGetPost :: (MonadState s m, MonadIO m) => CMSLens b s -> CMSKey -> m (Maybe Object) +wpGetPost cmsLens wpKey = + do wp <- use cmsLens liftIO $ getPost wp wpKey -getPost :: Wordpress b -> WPKey -> IO (Maybe Object) -getPost Wordpress{..} wpKey = decodePost <$> cachingGetRetry wpKey +getPost :: CMS b -> CMSKey -> IO (Maybe Object) +getPost CMS{..} wpKey = decodePost <$> cachingGetRetry wpKey where decodePost :: Either StatusCode Text -> Maybe Object decodePost (Right t) = do post' <- decodeJson t @@ -333,11 +333,10 @@ transformName = T.append "wp" . snd . T.foldl f (True, "") 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 } +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/Types.hs b/src/Web/Offset/Types.hs index ad65e1b..254fb1e 100644 --- a/src/Web/Offset/Types.hs +++ b/src/Web/Offset/Types.hs @@ -28,44 +28,44 @@ 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) - } - -type WPLens b s = Lens' s (Wordpress b) +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 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 CMSConfig m = + CMSConfig { cmsConfEndpoint :: Text + , cmsConfRequest :: Either UserPassword Requester + , cmsConfCacheBehavior :: CacheBehavior + , cmsConfExtraFields :: [Field m] + , cmsConfLogger :: Maybe (Text -> IO ()) + } + +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 TaxSpec = TaxPlus Text | TaxMinus Text deriving (Eq, Ord) @@ -105,15 +105,15 @@ instance Show Filter where 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) +data CMSKey = 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 From ecc0b8190be6b129ea35b5deec5308dea5951123 Mon Sep 17 00:00:00 2001 From: Libby Horacek Date: Sat, 4 Mar 2017 10:12:58 -0500 Subject: [PATCH 02/11] Create more general CMSKey type --- spec/Common.hs | 14 +++---- spec/Main.hs | 2 +- src/Web/Offset.hs | 2 +- src/Web/Offset/Cache.hs | 21 ++--------- src/Web/Offset/Internal.hs | 24 +----------- src/Web/Offset/Queries.hs | 2 +- src/Web/Offset/Splices.hs | 30 +++++++-------- src/Web/Offset/Types.hs | 75 +++++++++++++++++++++++++++++++++----- 8 files changed, 97 insertions(+), 73 deletions(-) diff --git a/spec/Common.hs b/spec/Common.hs index b8b5376..97426b3 100644 --- a/spec/Common.hs +++ b/spec/Common.hs @@ -224,23 +224,23 @@ shouldRender t output = do -- Caching helpers -cmsCacheGet' :: S.MonadIO m => CMS b -> CMSKey -> m (Maybe Text) +cmsCacheGet' :: S.MonadIO m => CMS b -> WPKey -> m (Maybe Text) cmsCacheGet' cms' wpKey = do let CMSInt{..} = cacheInternals cms' - liftIO $ cmsCacheGet wpKey + liftIO $ cmsCacheGet (toCMSKey wpKey) -cmsCacheSet' :: S.MonadIO m => CMS b -> CMSKey -> Text -> m () +cmsCacheSet' :: S.MonadIO m => CMS b -> WPKey -> Text -> m () cmsCacheSet' cms' wpKey o = do let CMSInt{..} = cacheInternals cms' - liftIO $ cmsCacheSet wpKey o + liftIO $ cmsCacheSet (toCMSKey wpKey) o cmsExpireAggregates' :: S.MonadIO m => CMS t -> m Bool cmsExpireAggregates' CMS{..} = liftIO cmsExpireAggregates -cmsExpirePost' :: S.MonadIO m => CMS t -> CMSKey -> m Bool -cmsExpirePost' CMS{..} k = - liftIO $ cmsExpirePost k +cmsExpirePost' :: S.MonadIO m => CMS t -> WPKey -> m Bool +cmsExpirePost' CMS{..} wpKey = + liftIO $ cmsExpirePost (toCMSKey wpKey) {- shouldRenderAtUrlContaining' :: (TemplateName, Ctxt) diff --git a/spec/Main.hs b/spec/Main.hs index 6edf137..40c198f 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 diff --git a/src/Web/Offset.hs b/src/Web/Offset.hs index fa52ee7..9347c86 100644 --- a/src/Web/Offset.hs +++ b/src/Web/Offset.hs @@ -4,7 +4,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -17,6 +16,7 @@ module Web.Offset ( , wpGetPost , getPost , CMSKey(..) + , WPKey(..) , Filter(..) , transformName , TaxSpec(..) diff --git a/src/Web/Offset/Cache.hs b/src/Web/Offset/Cache.hs index d1a5079..75ec1f6 100644 --- a/src/Web/Offset/Cache.hs +++ b/src/Web/Offset/Cache.hs @@ -39,7 +39,7 @@ cachingGetRetryInt wp = retryUnless . cachingGetInt wp 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 = @@ -80,14 +80,14 @@ cachingGetInt CMSInt{..} wpKey = return $ Successful jsonBlob cmsCacheGetInt :: RunRedis -> CacheBehavior -> CMSKey -> IO (Maybe Text) -cmsCacheGetInt runRedis b = runRedis . cacheGet b . formatKey +cmsCacheGetInt runRedis b = runRedis . cacheGet b . cFormatKey cacheGet :: CacheBehavior -> Text -> Redis (Maybe Text) cacheGet NoCache _ = return Nothing cacheGet _ key = rget key cmsCacheSetInt :: RunRedis -> CacheBehavior -> CMSKey -> Text -> IO () -cmsCacheSetInt runRedis b key = void . runRedis . cacheSet b (formatKey key) +cmsCacheSetInt runRedis b key = void . runRedis . cacheSet b (cFormatKey key) cacheSet :: CacheBehavior -> Text -> Text -> Redis Bool cacheSet b k v = @@ -106,17 +106,4 @@ wpExpirePostInt :: RunRedis -> CMSKey -> IO Bool wpExpirePostInt runRedis = runRedis . expire expire :: CMSKey -> Redis Bool -expire key = rdel [formatKey key] >> expireAggregates - -formatKey :: CMSKey -> 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 key = rdel [cFormatKey key] >> expireAggregates diff --git a/src/Web/Offset/Internal.hs b/src/Web/Offset/Internal.hs index e39e069..3351cb1 100644 --- a/src/Web/Offset/Internal.hs +++ b/src/Web/Offset/Internal.hs @@ -18,28 +18,8 @@ import Web.Offset.Types import Web.Offset.Utils cmsRequestInt :: Requester -> Text -> CMSKey -> IO (Either StatusCode Text) -cmsRequestInt 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 :: CMSKey -> [(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 _ = [] +cmsRequestInt runHTTP endpt key = req (cRequestUrl key) + where req (path, params) = unRequester runHTTP (endpt <> path) params cmsLogInt :: Maybe (Text -> IO ()) -> Text -> IO () cmsLogInt logger msg = case logger of diff --git a/src/Web/Offset/Queries.hs b/src/Web/Offset/Queries.hs index 013ae69..8cabb72 100644 --- a/src/Web/Offset/Queries.hs +++ b/src/Web/Offset/Queries.hs @@ -34,7 +34,7 @@ lookupSpecId CMS{..} taxName spec = let key = TaxSlugKey taxName slug 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 cmsLogger $ "Cache lookup returned HTTP error code " <> tshow errCode diff --git a/src/Web/Offset/Splices.hs b/src/Web/Offset/Splices.hs index d1d204c..10e9dd9 100644 --- a/src/Web/Offset/Splices.hs +++ b/src/Web/Offset/Splices.hs @@ -61,7 +61,7 @@ wpCustomFill CMS{..} = useAttrs (a "endpoint") customFill where customFill endpoint = Fill $ \attrs (path, tpl) lib -> do let key = EndpointKey endpoint - res <- liftIO $ cachingGetRetry key + res <- liftIO $ cachingGetRetry (toCMSKey key) case fmap decode res of Left code -> do let notification = "Encountered status code " <> tshow code @@ -100,8 +100,8 @@ wpPostsFill :: CMS b wpPostsFill wp extraFields cmsLens = Fill $ \attrs tpl lib -> do let postsQuery = parseQueryNode (Map.toList attrs) filters <- liftIO $ mkFilters wp (qtaxes postsQuery) - let wpKey = mkCMSKey filters postsQuery - res <- liftIO $ cachingGetRetry wp wpKey + let wpKey = mkWPKey filters postsQuery + res <- liftIO $ cachingGetRetry wp (toCMSKey wpKey) case fmap decode res of Right (Just posts) -> do let postsW = extractPostIds posts @@ -145,7 +145,7 @@ wpPostByPermalinkFill extraFields getURI cmsLens = maybeFillChildrenWith' $ case mperma of Nothing -> return Nothing Just (year, month, slug) -> - do res <- wpGetPost cmsLens (PostByPermalinkKey year month slug) + do res <- wpGetPost cmsLens (toCMSKey $ PostByPermalinkKey year month slug) case res of Just post -> do addPostIds cmsLens [fst (extractPostId post)] return $ Just (postSubs extraFields post) @@ -165,7 +165,7 @@ wpPageFill cmsLens = useAttrs (a "name") pageFill where pageFill Nothing = textFill "" pageFill (Just slug) = textFill' $ - do res <- wpGetPost cmsLens (PageKey slug) + do res <- wpGetPost 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 @@ -226,7 +226,7 @@ filterTaxonomies attrs = map attrToTaxSpecList taxAttrs taxDictKeys :: [TaxSpecList] -> [CMSKey] -taxDictKeys = map (\(TaxSpecList tName _) -> TaxDictKey tName) +taxDictKeys = map (\(TaxSpecList tName _) -> toCMSKey $ TaxDictKey tName) mkPostsQuery :: Maybe Int -> Maybe Int @@ -254,25 +254,25 @@ wpPrefetch wp extra uri cmsLens = Fill $ \ _m (p, tpl) l -> do mKeys <- liftIO $ newMVar [] void $ runTemplate tpl p (prefetchSubs wp mKeys) l wpKeys <- liftIO $ readMVar mKeys - void $ liftIO $ concurrently $ map cachingGet wpKeys + void $ liftIO $ concurrently $ map cachingGet (map toCMSKey wpKeys) runTemplate tpl p (wordpressSubs wp extra uri cmsLens) l -prefetchSubs :: CMS b -> MVar [CMSKey] -> Substitutions s +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 [CMSKey] + -> MVar [WPKey] -> Fill s wpPostsPrefetch wp mKeys = Fill $ \attrs _ _ -> do let postsQuery = parseQueryNode (Map.toList attrs) filters <- liftIO $ mkFilters wp (qtaxes postsQuery) - let key = mkCMSKey filters postsQuery + let key = mkWPKey filters postsQuery liftIO $ modifyMVar_ mKeys (\keys -> return $ key : keys) return "" -wpPagePrefetch :: MVar [CMSKey] +wpPagePrefetch :: MVar [WPKey] -> Text -> Fill s wpPagePrefetch mKeys name = textFill' $ @@ -280,10 +280,10 @@ wpPagePrefetch mKeys name = textFill' $ liftIO $ modifyMVar_ mKeys (\keys -> return $ key : keys) return "" -mkCMSKey :: [Filter] - -> WPQuery - -> CMSKey -mkCMSKey taxFilters WPPostsQuery{..} = +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] diff --git a/src/Web/Offset/Types.hs b/src/Web/Offset/Types.hs index 254fb1e..b3e5fcd 100644 --- a/src/Web/Offset/Types.hs +++ b/src/Web/Offset/Types.hs @@ -20,6 +20,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 @@ -105,15 +106,71 @@ instance Show Filter where show (OffsetFilter n) = "offset_" ++ show n show (UserFilter u) = T.unpack $ "user_" <> u -data CMSKey = PostKey Int - | PostByPermalinkKey Year Month Slug - | PostsKey (Set Filter) - | PageKey Text - | AuthorKey Int - | TaxDictKey Text - | TaxSlugKey TaxonomyName Slug - | EndpointKey Text - deriving (Eq, Show, Ord) +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 + +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) + EndpointKey endpoint -> + CMSKey ("/" <> endpoint, []) + (ns "endpoint:" <> endpoint) + (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) + +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 From c33f71a813118f4adc9f7f960b6150a2807a4825 Mon Sep 17 00:00:00 2001 From: Libby Horacek Date: Sat, 4 Mar 2017 10:59:09 -0500 Subject: [PATCH 03/11] Move WordPress-specific code to WordPress modules --- src/Web/Offset/Field.hs | 47 ------ src/Web/Offset/Init.hs | 18 ++- src/Web/Offset/Splices.hs | 205 +----------------------- src/Web/Offset/Splices/Helpers.hs | 25 +++ src/Web/Offset/Utils.hs | 10 ++ src/Web/Offset/WordPress/Field.hs | 48 ++++++ src/Web/Offset/WordPress/Splices.hs | 239 ++++++++++++++++++++++++++++ 7 files changed, 338 insertions(+), 254 deletions(-) create mode 100644 src/Web/Offset/Splices/Helpers.hs create mode 100644 src/Web/Offset/WordPress/Field.hs create mode 100644 src/Web/Offset/WordPress/Splices.hs 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 a73cf23..6c15a65 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,12 +16,13 @@ import Web.Offset.HTTP import Web.Offset.Internal import Web.Offset.Splices import Web.Offset.Types +import Web.Offset.WordPress.Splices initCMS :: CMSConfig s - -> R.Connection - -> StateT s IO Text - -> CMSLens b s - -> IO (CMS b, Substitutions 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 = cmsLogInt $ cmsConfLogger cmsconf @@ -45,4 +47,4 @@ initCMS cmsconf redis getURI cmsLens = do , cmsLogger = logf } let extraFields = cmsConfExtraFields cmsconf - return (cms, wordpressSubs cms extraFields getURI cmsLens) + return (cms, (wordPressSubs <> cmsSubs) cms extraFields getURI cmsLens) diff --git a/src/Web/Offset/Splices.hs b/src/Web/Offset/Splices.hs index 10e9dd9..15f66df 100644 --- a/src/Web/Offset/Splices.hs +++ b/src/Web/Offset/Splices.hs @@ -32,19 +32,15 @@ import Web.Offset.Posts import Web.Offset.Queries import Web.Offset.Types import Web.Offset.Utils +import Web.Offset.Splices.Helpers -wordpressSubs :: CMS b +cmsSubs :: 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) - , ("wpCustom", wpCustomFill wp) +cmsSubs wp extraFields getURI cmsLens = + subs [ ("wpCustom", wpCustomFill wp) , ("wpCustomDate", wpCustomDateFill)] wpCustomDateFill :: Fill s @@ -92,90 +88,8 @@ jsonToFill (Number n) = case floatingOrInteger n of jsonToFill (Bool b) = textFill $ tshow b jsonToFill (Null) = textFill "" - -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 (postSubs 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 <- wpGetPost cmsLens (toCMSKey $ PostByPermalinkKey year month slug) - case res of - Just post -> do addPostIds cmsLens [fst (extractPostId post)] - return $ Just (postSubs 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 <- wpGetPost 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 - _ -> "" - _ -> "" - _ -> "" - -postSubs :: [Field s] -> Object -> Substitutions s -postSubs extra object = subs (map (buildSplice object) (mergeFields postFields extra)) +fieldSubs :: [Field s] -> Object -> Substitutions s +fieldSubs fields object = subs (map (buildSplice object) fields) where buildSplice o (F n) = (transformName n, textFill $ getText n o) buildSplice o (P n fill') = @@ -210,106 +124,6 @@ postSubs extra object = subs (map (buildSplice object) (mergeFields postFields e -- * -- 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) - wpGetPost :: (MonadState s m, MonadIO m) => CMSLens b s -> CMSKey -> m (Maybe Object) wpGetPost cmsLens wpKey = do wp <- use cmsLens @@ -325,7 +139,6 @@ getPost CMS{..} wpKey = decodePost <$> cachingGetRetry wpKey _ -> 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)) @@ -333,10 +146,4 @@ transformName = T.append "wp" . snd . T.foldl f (True, "") f (False, rest) '-' = (True, rest) f (False, rest) next = (False, T.snoc rest next) -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/Splices/Helpers.hs b/src/Web/Offset/Splices/Helpers.hs new file mode 100644 index 0000000..a5745d7 --- /dev/null +++ b/src/Web/Offset/Splices/Helpers.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module Web.Offset.Splices.Helpers 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.Utils + +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 diff --git a/src/Web/Offset/Utils.hs b/src/Web/Offset/Utils.hs index 9ff38f4..2cae90b 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,10 @@ concurrently [a] = concurrently (a:as) = do (r1, rs) <- CC.concurrently a (concurrently as) return (r1:rs) + +parseWPDate :: Text -> Text -> Maybe UTCTime +parseWPDate wpFormat date = + parseTimeM False + defaultTimeLocale + (T.unpack wpFormat) + (T.unpack date) :: Maybe UTCTime diff --git a/src/Web/Offset/WordPress/Field.hs b/src/Web/Offset/WordPress/Field.hs new file mode 100644 index 0000000..d626f0e --- /dev/null +++ b/src/Web/Offset/WordPress/Field.hs @@ -0,0 +1,48 @@ +{-# 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.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 parseWPDate wpFormat date of + Just d -> fillChildrenWith $ datePartSubs d + Nothing -> textFill $ "" diff --git a/src/Web/Offset/WordPress/Splices.hs b/src/Web/Offset/WordPress/Splices.hs new file mode 100644 index 0000000..6810e11 --- /dev/null +++ b/src/Web/Offset/WordPress/Splices.hs @@ -0,0 +1,239 @@ +{-# 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.Posts +import Web.Offset.Queries +import Web.Offset.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)] + +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 (fieldSubs (mergeFields postFields 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 <- wpGetPost cmsLens (toCMSKey $ PostByPermalinkKey year month slug) + case res of + Just post -> do addPostIds cmsLens [fst (extractPostId post)] + return $ Just (fieldSubs (mergeFields postFields 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 <- wpGetPost 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) #-} From 5cceb7c3ad5fb48da52700c063f6dd9d0420fca8 Mon Sep 17 00:00:00 2001 From: Libby Horacek Date: Sat, 4 Mar 2017 11:31:18 -0500 Subject: [PATCH 04/11] Remove references to WordPress from parseDate --- src/Web/Offset/Splices.hs | 2 +- src/Web/Offset/Utils.hs | 6 +++--- src/Web/Offset/WordPress/Field.hs | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Web/Offset/Splices.hs b/src/Web/Offset/Splices.hs index 15f66df..3ee66d6 100644 --- a/src/Web/Offset/Splices.hs +++ b/src/Web/Offset/Splices.hs @@ -48,7 +48,7 @@ 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 + case parseDate wpFormat date of Just d -> fillChildrenWith $ datePartSubs d Nothing -> textFill $ "" diff --git a/src/Web/Offset/Utils.hs b/src/Web/Offset/Utils.hs index 2cae90b..78e4431 100644 --- a/src/Web/Offset/Utils.hs +++ b/src/Web/Offset/Utils.hs @@ -49,9 +49,9 @@ concurrently (a:as) = do (r1, rs) <- CC.concurrently a (concurrently as) return (r1:rs) -parseWPDate :: Text -> Text -> Maybe UTCTime -parseWPDate wpFormat date = +parseDate :: Text -> Text -> Maybe UTCTime +parseDate format date = parseTimeM False defaultTimeLocale - (T.unpack wpFormat) + (T.unpack format) (T.unpack date) :: Maybe UTCTime diff --git a/src/Web/Offset/WordPress/Field.hs b/src/Web/Offset/WordPress/Field.hs index d626f0e..0b34fc3 100644 --- a/src/Web/Offset/WordPress/Field.hs +++ b/src/Web/Offset/WordPress/Field.hs @@ -43,6 +43,6 @@ postFields = [F "id" wpDateFill :: Text -> Fill s wpDateFill date = let wpFormat = "%Y-%m-%dT%H:%M:%S" in - case parseWPDate wpFormat date of + case parseDate wpFormat date of Just d -> fillChildrenWith $ datePartSubs d Nothing -> textFill $ "" From a1e9a25d95cd7cda711724c8e50fb66a769fe9f6 Mon Sep 17 00:00:00 2001 From: Libby Horacek Date: Sat, 4 Mar 2017 11:39:46 -0500 Subject: [PATCH 05/11] Move cmsLogInt to Utils, rename to useLogger --- src/Web/Offset/Init.hs | 3 ++- src/Web/Offset/Internal.hs | 5 ----- src/Web/Offset/Utils.hs | 5 +++++ 3 files changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Web/Offset/Init.hs b/src/Web/Offset/Init.hs index 6c15a65..fb1162d 100644 --- a/src/Web/Offset/Init.hs +++ b/src/Web/Offset/Init.hs @@ -16,6 +16,7 @@ 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 initCMS :: CMSConfig s @@ -25,7 +26,7 @@ initCMS :: CMSConfig s -> IO (CMS b, Substitutions s) initCMS cmsconf redis getURI cmsLens = do let rrunRedis = R.runRedis redis - let logf = cmsLogInt $ cmsConfLogger cmsconf + let logf = useLogger $ cmsConfLogger cmsconf let wpReq = case cmsConfRequest cmsconf of Left (u,p) -> wreqRequester logf u p Right r -> r diff --git a/src/Web/Offset/Internal.hs b/src/Web/Offset/Internal.hs index 3351cb1..18867d3 100644 --- a/src/Web/Offset/Internal.hs +++ b/src/Web/Offset/Internal.hs @@ -20,8 +20,3 @@ import Web.Offset.Utils cmsRequestInt :: Requester -> Text -> CMSKey -> IO (Either StatusCode Text) cmsRequestInt runHTTP endpt key = req (cRequestUrl key) where req (path, params) = unRequester runHTTP (endpt <> path) params - -cmsLogInt :: Maybe (Text -> IO ()) -> Text -> IO () -cmsLogInt logger msg = case logger of - Nothing -> return () - Just f -> f msg diff --git a/src/Web/Offset/Utils.hs b/src/Web/Offset/Utils.hs index 78e4431..4695891 100644 --- a/src/Web/Offset/Utils.hs +++ b/src/Web/Offset/Utils.hs @@ -55,3 +55,8 @@ parseDate format date = 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 From a4316fed804c9dece79f639fe8588ba2e98c4e35 Mon Sep 17 00:00:00 2001 From: Libby Horacek Date: Sat, 4 Mar 2017 11:42:23 -0500 Subject: [PATCH 06/11] Move Posts to WordPress.Posts --- offset.cabal | 4 ++-- src/Web/Offset/Splices.hs | 1 - src/Web/Offset/{ => WordPress}/Posts.hs | 2 +- src/Web/Offset/WordPress/Splices.hs | 2 +- 4 files changed, 4 insertions(+), 5 deletions(-) rename src/Web/Offset/{ => WordPress}/Posts.hs (96%) diff --git a/offset.cabal b/offset.cabal index 5a5e0e3..583ca64 100644 --- a/offset.cabal +++ b/offset.cabal @@ -26,8 +26,8 @@ library , Web.Offset.Cache , Web.Offset.Cache.Types , Web.Offset.Cache.Redis - , Web.Offset.Posts , Web.Offset.Utils + , Web.Offset.WordPress.Posts -- other-extensions: build-depends: aeson , base < 4.9 @@ -69,11 +69,11 @@ Test-Suite test-offset , Web.Offset.HTTP , Web.Offset.Init , Web.Offset.Internal - , Web.Offset.Posts , Web.Offset.Queries , Web.Offset.Splices , Web.Offset.Types , Web.Offset.Utils + , Web.Offset.WordPress.Posts build-depends: base , aeson , async diff --git a/src/Web/Offset/Splices.hs b/src/Web/Offset/Splices.hs index 3ee66d6..20669dc 100644 --- a/src/Web/Offset/Splices.hs +++ b/src/Web/Offset/Splices.hs @@ -28,7 +28,6 @@ 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 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/WordPress/Splices.hs b/src/Web/Offset/WordPress/Splices.hs index 6810e11..1bb3e22 100644 --- a/src/Web/Offset/WordPress/Splices.hs +++ b/src/Web/Offset/WordPress/Splices.hs @@ -28,8 +28,8 @@ import qualified Data.Vector as V import Web.Larceny import Web.Offset.Field -import Web.Offset.Posts import Web.Offset.Queries +import Web.Offset.WordPress.Posts import Web.Offset.Types import Web.Offset.Utils import Web.Offset.Splices From 7f0cbb976c7b566af0e2c1104f3a3738bb47bcb8 Mon Sep 17 00:00:00 2001 From: Libby Horacek Date: Sat, 4 Mar 2017 11:48:21 -0500 Subject: [PATCH 07/11] Move WordPress types to WordPress.Types --- offset.cabal | 2 + spec/Common.hs | 33 +++--- src/Web/Offset.hs | 3 +- src/Web/Offset/Splices.hs | 8 +- src/Web/Offset/Types.hs | 135 ------------------------ src/Web/Offset/WordPress/Splices.hs | 3 +- src/Web/Offset/WordPress/Types.hs | 154 ++++++++++++++++++++++++++++ 7 files changed, 181 insertions(+), 157 deletions(-) create mode 100644 src/Web/Offset/WordPress/Types.hs diff --git a/offset.cabal b/offset.cabal index 583ca64..ff1d6af 100644 --- a/offset.cabal +++ b/offset.cabal @@ -28,6 +28,7 @@ library , Web.Offset.Cache.Redis , Web.Offset.Utils , Web.Offset.WordPress.Posts + , Web.Offset.WordPress.Types -- other-extensions: build-depends: aeson , base < 4.9 @@ -74,6 +75,7 @@ Test-Suite test-offset , Web.Offset.Types , Web.Offset.Utils , Web.Offset.WordPress.Posts + , Web.Offset.WordPress.Types build-depends: base , aeson , async diff --git a/spec/Common.hs b/spec/Common.hs index 97426b3..1ebae5d 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,6 +33,7 @@ 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. -- diff --git a/src/Web/Offset.hs b/src/Web/Offset.hs index 9347c86..9716e5a 100644 --- a/src/Web/Offset.hs +++ b/src/Web/Offset.hs @@ -20,8 +20,6 @@ module Web.Offset ( , Filter(..) , transformName , TaxSpec(..) - , TagType - , CatType , TaxSpecList(..) , Field(..) , mergeFields @@ -34,3 +32,4 @@ import Web.Offset.HTTP import Web.Offset.Init import Web.Offset.Splices import Web.Offset.Types +import Web.Offset.WordPress.Types diff --git a/src/Web/Offset/Splices.hs b/src/Web/Offset/Splices.hs index 20669dc..3c6b2e1 100644 --- a/src/Web/Offset/Splices.hs +++ b/src/Web/Offset/Splices.hs @@ -31,7 +31,7 @@ import Web.Offset.Field import Web.Offset.Queries import Web.Offset.Types import Web.Offset.Utils -import Web.Offset.Splices.Helpers +import Web.Offset.Splices.Helpers cmsSubs :: CMS b -> [Field s] @@ -55,8 +55,10 @@ wpCustomFill :: CMS b -> Fill s wpCustomFill CMS{..} = useAttrs (a "endpoint") customFill where customFill endpoint = Fill $ \attrs (path, tpl) lib -> - do let key = EndpointKey endpoint - res <- liftIO $ cachingGetRetry (toCMSKey key) + 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 diff --git a/src/Web/Offset/Types.hs b/src/Web/Offset/Types.hs index b3e5fcd..61faf2f 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 #-} @@ -68,44 +67,6 @@ data CMSInt b = , 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 CMSKey = CMSKey { cRequestUrl :: (Text, [(Text, Text)]) , cFormatKey :: Text , cShow :: Text } @@ -115,102 +76,6 @@ instance Ord CMSKey where instance Eq CMSKey where key1 == key2 = cShow key1 == cShow key2 -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) - EndpointKey endpoint -> - CMSKey ("/" <> endpoint, []) - (ns "endpoint:" <> endpoint) - (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) - -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 WPQuery = WPPostsQuery{ qlimit :: Int - , qnum :: Int - , qoffset :: Int - , qpage :: Int - , qtaxes :: [TaxSpecList] - , quser :: Maybe Text - } deriving (Show) - type StatusCode = Int data CacheResult a = Successful a -- cache worked as expected diff --git a/src/Web/Offset/WordPress/Splices.hs b/src/Web/Offset/WordPress/Splices.hs index 1bb3e22..328bc34 100644 --- a/src/Web/Offset/WordPress/Splices.hs +++ b/src/Web/Offset/WordPress/Splices.hs @@ -31,8 +31,9 @@ import Web.Offset.Field import Web.Offset.Queries import Web.Offset.WordPress.Posts import Web.Offset.Types +import Web.Offset.WordPress.Types import Web.Offset.Utils -import Web.Offset.Splices +import Web.Offset.Splices import Web.Offset.WordPress.Field wordPressSubs :: CMS b 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) From 4d28bc2a859bf7d4bca325cd3cefafbd26a07833 Mon Sep 17 00:00:00 2001 From: Libby Horacek Date: Sat, 4 Mar 2017 11:49:09 -0500 Subject: [PATCH 08/11] Move WordPress queries to WordPress.Queries Add other WordPress modules to cabal file --- offset.cabal | 10 ++++++++-- src/Web/Offset/Splices.hs | 1 - src/Web/Offset/{ => WordPress}/Queries.hs | 5 +++-- src/Web/Offset/WordPress/Splices.hs | 2 +- 4 files changed, 12 insertions(+), 6 deletions(-) rename src/Web/Offset/{ => WordPress}/Queries.hs (93%) diff --git a/offset.cabal b/offset.cabal index ff1d6af..bbfc933 100644 --- a/offset.cabal +++ b/offset.cabal @@ -21,13 +21,16 @@ 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.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 @@ -70,11 +73,14 @@ Test-Suite test-offset , Web.Offset.HTTP , Web.Offset.Init , Web.Offset.Internal - , 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 diff --git a/src/Web/Offset/Splices.hs b/src/Web/Offset/Splices.hs index 3c6b2e1..5428dc0 100644 --- a/src/Web/Offset/Splices.hs +++ b/src/Web/Offset/Splices.hs @@ -28,7 +28,6 @@ import qualified Data.Vector as V import Web.Larceny import Web.Offset.Field -import Web.Offset.Queries import Web.Offset.Types import Web.Offset.Utils import Web.Offset.Splices.Helpers diff --git a/src/Web/Offset/Queries.hs b/src/Web/Offset/WordPress/Queries.hs similarity index 93% rename from src/Web/Offset/Queries.hs rename to src/Web/Offset/WordPress/Queries.hs index 8cabb72..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 = diff --git a/src/Web/Offset/WordPress/Splices.hs b/src/Web/Offset/WordPress/Splices.hs index 328bc34..6617e93 100644 --- a/src/Web/Offset/WordPress/Splices.hs +++ b/src/Web/Offset/WordPress/Splices.hs @@ -28,8 +28,8 @@ import qualified Data.Vector as V import Web.Larceny import Web.Offset.Field -import Web.Offset.Queries import Web.Offset.WordPress.Posts +import Web.Offset.WordPress.Queries import Web.Offset.Types import Web.Offset.WordPress.Types import Web.Offset.Utils From e21bd79e2ef56d1214c887ad90ddd494e2da27a8 Mon Sep 17 00:00:00 2001 From: Libby Horacek Date: Sat, 4 Mar 2017 18:37:53 -0500 Subject: [PATCH 09/11] Change `(wp)(g/G)etPost` to `getSingle` Since it's not WordPress-specific -- seems like it should work for any endpoint with a single object. --- src/Web/Offset.hs | 4 ++-- src/Web/Offset/Splices.hs | 22 +++++++++++----------- src/Web/Offset/WordPress/Splices.hs | 4 ++-- 3 files changed, 15 insertions(+), 15 deletions(-) diff --git a/src/Web/Offset.hs b/src/Web/Offset.hs index 9716e5a..8c70726 100644 --- a/src/Web/Offset.hs +++ b/src/Web/Offset.hs @@ -13,8 +13,8 @@ module Web.Offset ( , Requester(..) , CacheBehavior(..) , initCMS - , wpGetPost - , getPost + , cmsGetSingle + , getSingle , CMSKey(..) , WPKey(..) , Filter(..) diff --git a/src/Web/Offset/Splices.hs b/src/Web/Offset/Splices.hs index 5428dc0..3a72bdf 100644 --- a/src/Web/Offset/Splices.hs +++ b/src/Web/Offset/Splices.hs @@ -124,20 +124,20 @@ fieldSubs fields object = subs (map (buildSplice object) fields) -- * -- Internal -- * -- -wpGetPost :: (MonadState s m, MonadIO m) => CMSLens b s -> CMSKey -> m (Maybe Object) -wpGetPost cmsLens wpKey = +cmsGetSingle :: (MonadState s m, MonadIO m) => CMSLens b s -> CMSKey -> m (Maybe Object) +cmsGetSingle cmsLens wpKey = do wp <- use cmsLens - liftIO $ getPost wp wpKey + liftIO $ getSingle wp wpKey -getPost :: CMS b -> CMSKey -> IO (Maybe Object) -getPost CMS{..} 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 +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 + decodeObj (Left _) = Nothing transformName :: Text -> Text transformName = T.append "wp" . snd . T.foldl f (True, "") diff --git a/src/Web/Offset/WordPress/Splices.hs b/src/Web/Offset/WordPress/Splices.hs index 6617e93..bf6da2d 100644 --- a/src/Web/Offset/WordPress/Splices.hs +++ b/src/Web/Offset/WordPress/Splices.hs @@ -100,7 +100,7 @@ wpPostByPermalinkFill extraFields getURI cmsLens = maybeFillChildrenWith' $ case mperma of Nothing -> return Nothing Just (year, month, slug) -> - do res <- wpGetPost cmsLens (toCMSKey $ PostByPermalinkKey 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 (fieldSubs (mergeFields postFields extraFields) post) @@ -120,7 +120,7 @@ wpPageFill cmsLens = useAttrs (a "name") pageFill where pageFill Nothing = textFill "" pageFill (Just slug) = textFill' $ - do res <- wpGetPost cmsLens (toCMSKey $ PageKey slug) + 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 From 791c40347995144cebde2c733c0b062013859c5a Mon Sep 17 00:00:00 2001 From: Libby Horacek Date: Sat, 4 Mar 2017 18:44:56 -0500 Subject: [PATCH 10/11] Blank prefixes ("wp") may be customized Default is now "cms". Also changed the names of some of the functions to be "cms" instead of "wp" --- spec/Common.hs | 6 +-- spec/Main.hs | 28 ++++++------- spec/Misc.hs | 23 ++++++++--- src/Web/Offset.hs | 1 + src/Web/Offset/Splices.hs | 63 +++++++++++++---------------- src/Web/Offset/Splices/Helpers.hs | 25 +++++++++--- src/Web/Offset/Types.hs | 6 +++ src/Web/Offset/WordPress/Field.hs | 3 +- src/Web/Offset/WordPress/Splices.hs | 7 +++- 9 files changed, 96 insertions(+), 66 deletions(-) diff --git a/spec/Common.hs b/spec/Common.hs index 1ebae5d..0380ee9 100644 --- a/spec/Common.hs +++ b/spec/Common.hs @@ -120,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 -> diff --git a/spec/Main.hs b/spec/Main.hs index 40c198f..f64ce1f 100644 --- a/spec/Main.hs +++ b/spec/Main.hs @@ -91,24 +91,24 @@ larcenyFillTests = do 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 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 8c70726..01166f4 100644 --- a/src/Web/Offset.hs +++ b/src/Web/Offset.hs @@ -31,5 +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/Splices.hs b/src/Web/Offset/Splices.hs index 3a72bdf..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) @@ -32,26 +31,26 @@ import Web.Offset.Types import Web.Offset.Utils import Web.Offset.Splices.Helpers -cmsSubs :: CMS b - -> [Field s] - -> StateT s IO Text - -> CMSLens b s - -> Substitutions s +cmsSubs :: CMS b + -> [Field s] + -> StateT s IO Text + -> CMSLens b s + -> Substitutions s cmsSubs wp extraFields getURI cmsLens = - subs [ ("wpCustom", wpCustomFill wp) - , ("wpCustomDate", wpCustomDateFill)] + subs [ ("cmsCustom", cmsCustomFill wp) + , ("cmsCustomDate", cmsCustomDateFill)] -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 parseDate wpFormat date of - Just d -> fillChildrenWith $ datePartSubs d +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 :: CMS b -> Fill s -wpCustomFill CMS{..} = +cmsCustomFill :: CMS b -> Fill s +cmsCustomFill CMS{..} = useAttrs (a "endpoint") customFill where customFill endpoint = Fill $ \attrs (path, tpl) lib -> do let key = CMSKey ("/" <> endpoint, []) @@ -75,7 +74,7 @@ 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) = @@ -88,26 +87,26 @@ jsonToFill (Number n) = case floatingOrInteger n of jsonToFill (Bool b) = textFill $ tshow b jsonToFill (Null) = textFill "" -fieldSubs :: [Field s] -> Object -> Substitutions s -fieldSubs fields object = subs (map (buildSplice object) fields) +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)) @@ -121,6 +120,7 @@ fieldSubs fields object = subs (map (buildSplice object) fields) Just (Number i) -> either (tshow :: Double -> Text) (tshow :: Integer -> Text) (floatingOrInteger i) _ -> "" + transformNameP = transformName prefix -- * -- Internal -- * -- @@ -139,11 +139,4 @@ getSingle CMS{..} wpKey = decodeObj <$> cachingGetRetry wpKey _ -> Nothing decodeObj (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) - {-# ANN module ("HLint: ignore Eta reduce" :: String) #-} diff --git a/src/Web/Offset/Splices/Helpers.hs b/src/Web/Offset/Splices/Helpers.hs index a5745d7..7bdd019 100644 --- a/src/Web/Offset/Splices/Helpers.hs +++ b/src/Web/Offset/Splices/Helpers.hs @@ -3,7 +3,9 @@ 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) @@ -12,14 +14,25 @@ import Data.Time.Clock (UTCTime) import Data.Time.Format (defaultTimeLocale, formatTime, parseTimeM) import Web.Larceny +import Web.Offset.Types import Web.Offset.Utils -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 = +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 61faf2f..f23cfe1 100644 --- a/src/Web/Offset/Types.hs +++ b/src/Web/Offset/Types.hs @@ -67,6 +67,12 @@ data CMSInt b = , 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 } diff --git a/src/Web/Offset/WordPress/Field.hs b/src/Web/Offset/WordPress/Field.hs index 0b34fc3..9dd797f 100644 --- a/src/Web/Offset/WordPress/Field.hs +++ b/src/Web/Offset/WordPress/Field.hs @@ -15,6 +15,7 @@ import Web.Larceny import Web.Offset.Field import Web.Offset.Splices.Helpers +import Web.Offset.Types import Web.Offset.Utils postFields :: [Field s] @@ -44,5 +45,5 @@ wpDateFill :: Text -> Fill s wpDateFill date = let wpFormat = "%Y-%m-%dT%H:%M:%S" in case parseDate wpFormat date of - Just d -> fillChildrenWith $ datePartSubs d + Just d -> fillChildrenWith $ datePartSubs (Prefix "wp") d Nothing -> textFill $ "" diff --git a/src/Web/Offset/WordPress/Splices.hs b/src/Web/Offset/WordPress/Splices.hs index bf6da2d..5fcde4b 100644 --- a/src/Web/Offset/WordPress/Splices.hs +++ b/src/Web/Offset/WordPress/Splices.hs @@ -48,6 +48,9 @@ wordPressSubs wp extraFields getURI 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 @@ -88,7 +91,7 @@ mkFilters wp specLists = wpPostsHelper :: [Field s] -> [Object] -> Fill s -wpPostsHelper extraFields postsND = mapSubs (fieldSubs (mergeFields postFields extraFields)) postsND +wpPostsHelper extraFields postsND = mapSubs (wpFieldSubs extraFields) postsND wpPostByPermalinkFill :: [Field s] -> StateT s IO Text @@ -103,7 +106,7 @@ wpPostByPermalinkFill extraFields getURI cmsLens = maybeFillChildrenWith' $ do res <- cmsGetSingle cmsLens (toCMSKey $ PostByPermalinkKey year month slug) case res of Just post -> do addPostIds cmsLens [fst (extractPostId post)] - return $ Just (fieldSubs (mergeFields postFields extraFields) post) + return $ Just (wpFieldSubs extraFields post) _ -> return Nothing wpNoPostDuplicatesFill :: CMSLens b s -> Fill s From 53a32e23f9f9817ee9724ec2e58cabaa63e2a510 Mon Sep 17 00:00:00 2001 From: Libby Horacek Date: Sat, 4 Mar 2017 18:50:52 -0500 Subject: [PATCH 11/11] Fix missed 'wp' prefix --- spec/Common.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/spec/Common.hs b/spec/Common.hs index 0380ee9..fb16db7 100644 --- a/spec/Common.hs +++ b/spec/Common.hs @@ -122,7 +122,7 @@ tplLibrary = ,(["fields"], parse "") ,(["custom-endpoint-object"], parse "") ,(["custom-endpoint-array"], parse "") - ,(["custom-endpoint-enter-the-matrix"], parse "") + ,(["custom-endpoint-enter-the-matrix"], parse "") ] renderLarceny :: Ctxt ->