diff --git a/spec/Main.hs b/spec/Main.hs index dc91e3a..fa04222 100644 --- a/spec/Main.hs +++ b/spec/Main.hs @@ -11,6 +11,7 @@ import Prelude hiding ((++)) import Blaze.ByteString.Builder import Configuration.Dotenv (loadFile) import Control.Concurrent.MVar +import Control.Exception (throw) import Control.Lens hiding ((.=)) import Control.Monad (mplus, void, when) import Control.Monad.State (StateT, evalStateT) @@ -116,6 +117,7 @@ tplLibrary = ,(["custom-endpoint-object"], parse "") ,(["custom-endpoint-array"], parse "") ,(["custom-endpoint-enter-the-matrix"], parse "") + ,(["custom-endpoint-404"], parse "") ] renderLarceny :: Ctxt -> @@ -129,34 +131,34 @@ renderLarceny ctxt name = return $ Just rendered _ -> return Nothing -fauxRequester :: Maybe (MVar [Text]) -> Text -> [(Text, Text)] -> IO (Either StatusCode Text) +fauxRequester :: Maybe (MVar [Text]) -> Text -> [(Text, Text)] -> IO Text fauxRequester _ "/wp/v2/tags" [("slug", "home-featured")] = - return $ Right $ enc [object [ "id" .= (177 :: Int) + return $ enc [object [ "id" .= (177 :: Int) , "slug" .= ("home-featured" :: Text) ]] fauxRequester _ "/wp/v2/tags" [("slug", "featured-global")] = - return $ Right $ enc [object [ "id" .= (160 :: Int) + return $ enc [object [ "id" .= (160 :: Int) , "slug" .= ("featured-global" :: Text) ]] fauxRequester _ "/wp/v2/categories" [("slug", "bookmarx")] = - return $ Right $ enc [object [ "id" .= (159 :: Int) + return $ enc [object [ "id" .= (159 :: Int) , "slug" .= ("bookmarx" :: Text) , "meta" .= object ["links" .= object ["self" .= ("/159" :: Text)]] ] ] fauxRequester _ "/jacobin/featured-content/editors-picks" [] = - return $ Right $ enc [object [ "post_date" .= ("2013-04-26 10:11:52" :: Text) + return $ enc [object [ "post_date" .= ("2013-04-26 10:11:52" :: Text) , "date" .= ("2014-04-26 10:11:52" :: Text) , "post_date_gmt" .= ("2015-04-26 15:11:52" :: Text) ]] fauxRequester _ "/wp/v2/pages" [("slug", "a-first-page")] = - return $ Right $ enc [page1] + return $ enc [page1] fauxRequester _ "/dev/null" [] = - return $ Right $ enc [object ["this_is_null" .= Null]] + return $ enc [object ["this_is_null" .= Null]] fauxRequester mRecord rqPath rqParams = do case mRecord of Just record -> modifyMVar_ record $ return . (<> [mkUrlUnescape rqPath rqParams]) Nothing -> return () - return $ Right $ enc [article1] + return $ enc [article1] where mkUrlUnescape url params = url <> "?" <> T.intercalate "&" (map (\(k, v) -> k <> "=" <> v) params) @@ -179,7 +181,7 @@ initFauxRequestNoCache = initializer (Right $ Requester (fauxRequester Nothing)) NoCache "" initNoRequestWithCache = - initializer (Right $ Requester (\_ _ -> return (Right "") )) (CacheSeconds 60) "" + initializer (Right $ Requester (\_ _ -> return "")) (CacheSeconds 60) "" ---------------------------------------------------------- -- Section 2: Test suite against application. -- @@ -204,7 +206,7 @@ clearRedisCache ctxt = R.runRedis (_redis ctxt) (rdelstar "wordpress:*") unobj :: Value -> Object unobj (Object x) = x -unobj _ = error "Not an object" +unobj _ = throw NotAnObject toTpl tpl = parse (TL.fromStrict tpl) @@ -426,6 +428,7 @@ shouldRenderContaining :: (TemplateName, Ctxt) -> Text -> Expectation shouldRenderContaining (template, ctxt) match = do rendered <- renderLarceny ctxt template let rendered' = fromMaybe "" rendered + liftIO $ print rendered' (match `T.isInfixOf` rendered') `shouldBe` True shouldNotRenderContaining :: (TemplateName, Ctxt) -> Text -> Expectation @@ -484,12 +487,14 @@ liveTests = it "should be able to query custom taxonomies" $ do ("department", ctxt) `shouldRenderContaining` "A sports post" ("department", ctxt) `shouldNotRenderContaining` "A first post" - it "should be able to query custom endpoints" $ do + it "should be able to query custom endpoints (as object)" $ do ("custom-endpoint-object", ctxt) `shouldRenderContaining` "categories" ("custom-endpoint-object", ctxt) `shouldNotRenderContaining` "departments" - it "should be able to query custom endpoints" $ do + it "should be able to query custom endpoints (as array)" $ do ("custom-endpoint-array", ctxt) `shouldRenderContaining` "2014-10-01" ("custom-endpoint-array", ctxt) `shouldRenderContaining` "2014-10-02" ("custom-endpoint-array", ctxt) `shouldRenderContaining` "2014-10-15" it "should be able to reference fields from the custom endpoint in another custom endpoint query" $ do ("custom-endpoint-array", ctxt) `rendersSameAs` "custom-endpoint-enter-the-matrix" + it "should handle 404s without blowing up" $ + ("custom-endpoint-404", ctxt) `shouldRenderContaining` "404" diff --git a/src/Web/Offset/Cache.hs b/src/Web/Offset/Cache.hs index 710daa7..6a77a95 100644 --- a/src/Web/Offset/Cache.hs +++ b/src/Web/Offset/Cache.hs @@ -1,15 +1,20 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} module Web.Offset.Cache where import Control.Concurrent as CC import qualified Control.Concurrent.Async as CC import Control.Concurrent.MVar +import Control.Exception (Handler (..), catch, catches, handle, + onException, throw, try) import Control.Monad (void) import Data.Map (Map) import qualified Data.Map as Map +import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import qualified Data.Set as Set import Data.Text (Text) @@ -36,50 +41,33 @@ stopReqMutexInt :: MVar (Map WPKey UTCTime) -> WPKey -> IO () stopReqMutexInt activeMV wpKey = modifyMVar_ activeMV $ return . Map.delete wpKey -cachingGetRetryInt :: WordpressInt b -> WPKey -> IO (Either StatusCode Text) +cachingGetRetryInt :: WordpressInt b -> WPKey -> IO Text cachingGetRetryInt wp = retryUnless . cachingGetInt wp cachingGetErrorInt :: WordpressInt b -> WPKey -> IO (Either StatusCode Text) cachingGetErrorInt wp wpKey = errorUnless msg (cachingGetInt wp wpKey) where msg = "Could not retrieve " <> tshow wpKey -retryUnless :: IO (CacheResult a) -> IO (Either StatusCode a) +retryUnless :: IO a -> IO a retryUnless action = - do ma <- action - case ma of - Successful r -> return $ Right r - Abort code -> return $ Left code - Retry -> do CC.threadDelay 100000 - retryUnless action - -errorUnless :: Text -> IO (CacheResult a) -> IO (Either StatusCode a) + catch action (\(e :: CacheInProgress) -> CC.threadDelay 100000 >> retryUnless action) + +errorUnless :: Text -> IO a -> IO (Either StatusCode a) errorUnless msg action = - do ma <- action - case ma of - Successful a -> return $ Right a - Abort code -> return $ Left code - Retry -> return $ Left 500 + (Right <$> action) `catches` + [ Handler (\(e :: StatusCodeException) -> return $ Left (code e)) + , Handler (\(e :: CacheInProgress) -> return $ Left 500) ] cachingGetInt :: WordpressInt b -> WPKey - -> IO (CacheResult Text) -cachingGetInt WordpressInt{..} wpKey = - do mCached <- wpCacheGet wpKey - case mCached of - Just cached -> return $ Successful cached - Nothing -> - do running <- startReqMutex wpKey - if running - then return Retry - else - do o <- wpRequest wpKey - case o of - Left errorCode -> - return $ Abort errorCode - Right jsonBlob -> do - wpCacheSet wpKey jsonBlob - stopReqMutex wpKey - return $ Successful jsonBlob + -> IO Text +cachingGetInt WordpressInt{..} wpKey = do + mCached <- wpCacheGet wpKey + fromMaybe getAndCache (return <$> mCached) + where getAndCache = do jsonBlob <- wpRequest wpKey + wpCacheSet wpKey jsonBlob + stopReqMutex wpKey + return jsonBlob wpCacheGetInt :: RunRedis -> CacheBehavior -> WPKey -> IO (Maybe Text) wpCacheGetInt runRedis b = runRedis . cacheGet b . formatKey diff --git a/src/Web/Offset/HTTP.hs b/src/Web/Offset/HTTP.hs index 506b274..98d3a6d 100644 --- a/src/Web/Offset/HTTP.hs +++ b/src/Web/Offset/HTTP.hs @@ -13,21 +13,20 @@ import qualified Network.Wreq as W newtype Requester = Requester { unRequester :: Text -> [(Text, Text)] - -> IO (Either Int Text) } + -> IO Text } wreqRequester :: (Text -> IO ()) -> Text -> Text -> Requester wreqRequester logger user passw = - Requester $ \u ps -> do let opts = W.defaults & W.params .~ ps - & W.auth ?~ W.basicAuth user' pass' - & W.checkStatus ?~ (\__ _ _ -> Nothing) - logger $ "wreq: " <> u <> " with params: " <> - (T.intercalate "&" . map (\(a,b) -> a <> "=" <> b) $ ps) - r <- W.getWith opts (T.unpack u) - case r ^. W.responseStatus ^. W.statusCode of - 200 -> return $ Right $ TL.toStrict . TL.decodeUtf8 $ r ^. W.responseBody - n -> return $ Left n + Requester $ \u ps -> + do let opts = W.defaults & W.params .~ ps + & W.auth ?~ W.basicAuth user' pass' + logger $ "wreq: " <> u <> " with params: " <> + (T.intercalate "&" . map (\(a,b) -> a <> "=" <> b) $ ps) + r <- W.getWith opts (T.unpack u) + return $ TL.toStrict . TL.decodeUtf8 + $ r ^. W.responseBody where user' = T.encodeUtf8 user pass' = T.encodeUtf8 passw diff --git a/src/Web/Offset/Internal.hs b/src/Web/Offset/Internal.hs index 7a08de9..30fa462 100644 --- a/src/Web/Offset/Internal.hs +++ b/src/Web/Offset/Internal.hs @@ -17,7 +17,7 @@ import Web.Offset.HTTP import Web.Offset.Types import Web.Offset.Utils -wpRequestInt :: Requester -> Text -> WPKey -> IO (Either StatusCode Text) +wpRequestInt :: Requester -> Text -> WPKey -> IO Text wpRequestInt runHTTP endpt key = case key of TaxDictKey resName -> req (defaultEndpoint <> "/" <> resName) [] diff --git a/src/Web/Offset/Queries.hs b/src/Web/Offset/Queries.hs index 3995201..3f34904 100644 --- a/src/Web/Offset/Queries.hs +++ b/src/Web/Offset/Queries.hs @@ -3,6 +3,7 @@ module Web.Offset.Queries where +import Control.Exception (throw) import Data.Monoid import Data.Text (Text) @@ -20,7 +21,7 @@ getSpecId taxDict spec = idFor :: TaxDict -> Text -> Int idFor (TaxDict{..}) slug = case filter (\(TaxRes (_,s)) -> s == slug) dict of - [] -> terror $ "Couldn't find " <> desc <> ": " <> slug + [] -> throw $ OtherException ("Couldn't find " <> desc <> ": " <> slug) (TaxRes (i,_):_) -> i lookupSpecId :: Wordpress b -> TaxonomyName -> TaxSpec -> IO (Maybe TaxSpecId) diff --git a/src/Web/Offset/Splices.hs b/src/Web/Offset/Splices.hs index 98828cb..1627329 100644 --- a/src/Web/Offset/Splices.hs +++ b/src/Web/Offset/Splices.hs @@ -10,6 +10,7 @@ module Web.Offset.Splices where import Control.Monad.State import Control.Applicative ((<|>)) import Control.Lens hiding (children) +import Control.Exception (try, SomeException) import Control.Concurrent.MVar import Control.Monad (void, sequence) import Control.Monad.Trans (lift, liftIO) @@ -70,19 +71,18 @@ wpCustomFill wp@Wordpress{..} = useAttrs (a "endpoint") customFill where customFill endpoint = Fill $ \attrs (path, tpl) lib -> do let key = EndpointKey endpoint - res <- liftIO $ cachingGetRetry key + res <- liftIO $ try (cachingGetRetry key) case fmap decode res of - Left code -> do - let notification = "Encountered status code " <> tshow code - <> " when querying \"" <> endpoint <> "\"." - liftIO $ wpLogger 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 return $ "" + Left (e :: SomeException) -> do + let notification = "Encountered error: " <> tshow e <> " when querying wpPosts." + liftIO $ wpLogger notification + return $ "" jsonToFill :: Value -> Fill s jsonToFill (Object o) = @@ -111,7 +111,7 @@ wpPostsFill wp@Wordpress{..} extraFields wpLens = Fill $ \attrs tpl lib -> let postsQuery = parseQueryNode (Map.toList attrs) filters <- liftIO $ mkFilters wp (qtaxes postsQuery) let wpKey = mkWPKey filters postsQuery - res <- liftIO $ cachingGetRetry wpKey + res <- liftIO $ try (cachingGetRetry wpKey) case fmap decode res of Right (Just posts) -> do let postsW = extractPostIds posts @@ -120,10 +120,12 @@ wpPostsFill wp@Wordpress{..} extraFields wpLens = Fill $ \attrs tpl lib -> . noDuplicates requestPostSet $ postsW addPostIds wpLens (map fst postsND) unFill (wpPostsHelper extraFields (map snd postsND)) mempty tpl lib - Right Nothing -> return "" - Left code -> do - let notification = "Encountered status code " <> tshow code - <> " when querying wpPosts." + Right Nothing -> do + let notification = "Unable to decode JSON for wpPosts" + liftIO $ wpLogger $ notification <> ": " <> tshow res + return $ "" + Left (e :: SomeException) -> do + let notification = "Encountered error: " <> tshow e <> " when querying wpPosts." liftIO $ wpLogger notification return $ "" where noDuplicates :: Maybe IntSet -> [(Int, Object)] -> [(Int, Object)] @@ -326,13 +328,12 @@ wpGetPost wpLens wpKey = getPost :: Wordpress b -> WPKey -> IO (Maybe Object) getPost Wordpress{..} wpKey = decodePost <$> cachingGetRetry wpKey - where decodePost :: Either StatusCode Text -> Maybe Object - decodePost (Right t) = + where decodePost :: Text -> Maybe Object + decodePost t = do post' <- decodeJson t case post' of Just (post:_) -> Just post _ -> Nothing - decodePost (Left code) = Nothing transformName :: Text -> Text diff --git a/src/Web/Offset/Types.hs b/src/Web/Offset/Types.hs index a447045..3b1de32 100644 --- a/src/Web/Offset/Types.hs +++ b/src/Web/Offset/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} @@ -11,6 +12,7 @@ module Web.Offset.Types where +import Control.Exception (Exception (..)) import Control.Lens hiding (children) import Control.Monad (mzero) import Control.Monad.State @@ -23,6 +25,7 @@ import Data.Monoid ((<>)) import Data.Set (Set) import Data.Text (Text) import qualified Data.Text as T +import Data.Typeable (Typeable (..)) import Web.Offset.Cache.Types import Web.Offset.Field @@ -33,8 +36,8 @@ 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) + , cachingGet :: WPKey -> IO Text + , cachingGetRetry :: WPKey -> IO Text , cachingGetError :: WPKey -> IO (Either StatusCode Text) , wpLogger :: Text -> IO () , cacheInternals :: WordpressInt (StateT b IO Text) @@ -56,7 +59,7 @@ data WordpressInt b = WordpressInt { wpCacheGet :: WPKey -> IO (Maybe Text) , wpCacheSet :: WPKey -> Text -> IO () , startReqMutex :: WPKey -> IO Bool - , wpRequest :: WPKey -> IO (Either StatusCode Text) + , wpRequest :: WPKey -> IO Text , stopReqMutex :: WPKey -> IO () , runRedis :: RunRedis } @@ -154,3 +157,17 @@ data CacheResult a = Successful a -- cache worked as expected | Retry -- cache didn't work, but keep trying | Abort StatusCode -- we got a 404 or something, no need to retry deriving (Show, Functor) + +data OffsetException = OtherException Text + | NotAnObject + deriving (Show, Typeable) + +instance Exception OffsetException + +newtype CacheInProgress = CacheInProgress () + deriving (Show, Typeable) +instance Exception CacheInProgress + +newtype StatusCodeException = StatusCodeException { code :: StatusCode } + deriving (Show, Typeable) +instance Exception StatusCodeException diff --git a/src/Web/Offset/Utils.hs b/src/Web/Offset/Utils.hs index a2747c3..d7ccca7 100644 --- a/src/Web/Offset/Utils.hs +++ b/src/Web/Offset/Utils.hs @@ -20,9 +20,6 @@ readSafe = fmap fst . listToMaybe . reads . T.unpack tshow :: Show a => a -> Text tshow = T.pack . show -terror :: Text -> a -terror = error . T.unpack - (=<<<) :: Monad r => (a -> r (Maybe b)) -> r (Maybe a) -> r (Maybe b) f =<<< g = maybe (return Nothing) f =<< g