Refactor to exceptions

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 "<wpCustom endpoint=\"wp/v2/taxonomies\"><wpCategory><wpRestBase /></wpCategory></wpCustom>")
              ,(["custom-endpoint-array"], parse "<wpCustom endpoint=\"wp/v2/posts\"><wpDate /></wpCustom>")
              ,(["custom-endpoint-enter-the-matrix"], parse "<wpCustom endpoint=\"wp/v2/posts\"><wpCustom endpoint=\"wp/v2/posts/${wpId}\"><wpDate /></wpCustom></wpCustom>")
+             ,(["custom-endpoint-404"], parse "<wpCustom endpoint=\"doesnt/exist\"></wpCustom>")
                ]
 
 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"

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

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

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) []

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)

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 $ "<!-- " <> notification <> " -->"
                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 $ "<!-- " <> notification <> "-->"
+               Left (e :: SomeException) -> do
+                 let notification = "Encountered error: " <> tshow e <> " when querying wpPosts."
+                 liftIO $ wpLogger notification
+                 return $ "<!-- " <> notification <> " -->"
 
 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 $ "<!-- " <> notification <> "-->"
+       Left (e :: SomeException) -> do
+         let notification = "Encountered error: " <> tshow e <> " when querying wpPosts."
          liftIO $ wpLogger notification
          return $ "<!-- " <> notification <> " -->"
   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

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

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