shelduck 0.1.3.0 → 0.1.4.0
raw patch · 9 files changed
+95/−62 lines, 9 filesdep −rainbow
Dependencies removed: rainbow
Files
- shelduck.cabal +1/−3
- src/Main.hs +1/−1
- src/Shelduck.hs +23/−45
- src/Shelduck/Configuration.hs +3/−0
- src/Shelduck/IntercomDefinitions.hs +13/−0
- src/Shelduck/Internal.hs +33/−0
- src/Shelduck/Keen.hs +1/−4
- src/Shelduck/Templating.hs +1/−1
- test/Tests.hs +19/−8
shelduck.cabal view
@@ -1,5 +1,5 @@ name: shelduck-version: 0.1.3.0+version: 0.1.4.0 -- synopsis: -- description: license: Apache-2.0@@ -30,7 +30,6 @@ , stm , wreq , aeson- , rainbow , hastache , random , bytestring@@ -53,7 +52,6 @@ , stm , wreq , aeson- , rainbow , hastache , random , bytestring
src/Main.hs view
@@ -7,7 +7,7 @@ printUsage :: IO () printUsage = mapM_ putStrLn usageLines- where usageLines = ["USAGE: scalp-webhooks <definition_type>", "Current definition_types: intercom"]+ where usageLines = ["USAGE: shelduck <definition_type>", "Current definition_types: intercom"] main = do args <- getArgs
src/Shelduck.hs view
@@ -17,26 +17,21 @@ doHandle ) where -import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM.TVar import Control.Lens hiding ((.=))-import Control.Lens.TH import Control.Monad import Control.Monad.STM import Control.Monad.Trans.Class-import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Data.Aeson import Data.Aeson.Lens import Data.ByteString.Lazy (toStrict) import qualified Data.ByteString.Lazy as L import Data.Maybe-import Data.Monoid import Data.Text import Data.Text.Encoding import qualified Network.Wreq as W-import Rainbow import Shelduck.Configuration import Shelduck.Internal import Shelduck.Keen@@ -45,18 +40,6 @@ import Shelly import Web.Spock.Safe -data WebhookRequest = WebhookRequest {- _requestEndpoint :: Text,- _requestOpts :: W.Options,- _requestParameters :: Value,- _requestTopic :: Text-}--blank :: WebhookRequest-blank = WebhookRequest mempty W.defaults (object []) mempty--$(makeLenses ''WebhookRequest)- data TimedResponse = TimedResponse { _response :: W.Response L.ByteString, _timing :: Int@@ -64,19 +47,20 @@ $(makeLenses ''TimedResponse) -type TopicResult = Maybe Text+type Topic = Text -doPost :: (WebhookRequest, Text, Text) -> ReaderT a IO (W.Response L.ByteString)+doPost :: RequestData -> ReaderT a IO (W.Response L.ByteString) doPost (w, e, p) = lift $ W.postWith (w ^. requestOpts) (unpack e) (encodeUtf8 p) doLog :: W.Response L.ByteString -> ReaderT a IO (W.Response L.ByteString)-doLog r = lift ((info . pack . show) (r ^. W.responseStatus)) >> return r+doLog r = lift ((info . json . pack . show) (r ^. W.responseStatus)) >> return r+ where json s = object ["status" .= s] -doWait :: Int -> W.Response L.ByteString -> ReaderT (TVar TopicResult) IO TimedResponse-doWait c x = ask >>=- \t -> lift $ do- (c, r) <- pollingIO c t predicate (return x)- return $ TimedResponse r c+doWait :: RequestData -> Int -> W.Response L.ByteString -> ReaderT (TVar TopicResult) IO TimedResponse+doWait d c x = do+ t <- ask+ (c, r) <- lift $ pollingIO c t predicate (return x)+ doRetry d doPost >> return (TimedResponse r c) where predicate t = fmap isJust (readTVarIO t) doHandle :: WebhookRequest -> ReaderT (TVar TopicResult) IO Bool@@ -87,7 +71,7 @@ sendToServices (w ^. requestTopic) pass return pass -sendToServices :: Text -> Bool -> IO ()+sendToServices :: Topic -> Bool -> IO () sendToServices t b = do sendToKeen t b unless b $ sendToSlack t b@@ -99,38 +83,32 @@ return b' doLogTimings :: Int -> TimedResponse -> IO ()-doLogTimings i t = void $ info $ mconcat ["Took approx: ", (pack . show) time, " microseconds..."]+doLogTimings i t = void $ info $ object ["duration" .= time] where time = (i - (t ^. timing)) * pollTime performRequest :: WebhookRequest -> ReaderT (TVar TopicResult) IO TimedResponse-performRequest w = doTemplating >>=- doPost >>=+performRequest w = doTemplating >>= \req ->+ doPost req >>= doLog >>=- doWait polls >>=- (\x -> lift (doLogTimings polls x) >> doHandle w >> return x)+ doWait req polls >>=+ (\x ->+ lift (doLogTimings polls x) >>+ doHandle w >> return x) where doTemplating = lift $ do e <- template (w ^. requestEndpoint) p <- template ((decodeUtf8 . toStrict . encode) $ w ^. requestParameters) return (w, e, p) -checkTopic :: Text -> Text -> IO Bool+checkTopic :: Topic -> Topic -> IO Bool checkTopic b t = if b == t- then success (mconcat [" Good topic: ", showResult b]) >> return True- else failure (mconcat [" Bad topic: ", showResult b]) >> return False+ then info (object ["good_topic" .= showResult b]) >> return True+ else info (object ["bad_topic" .= showResult b]) >> return False where showResult = pack . show -failure :: Text -> IO ()-failure x = putChunkLn $ chunk x & fore red--info :: Text -> IO ()-info x = putChunkLn $ chunk x & fore cyan--success :: Text -> IO ()-success x = putChunkLn $ chunk x & fore green- ngrok :: IO ()-ngrok = shelly $ verbosely $ run "ngrok" ["start", "shelduck"] >>= (liftIO . info)+ngrok = shelly $ verbosely $ run "ngrok" ["start", "shelduck"] >>= (liftIO . info . json)+ where json x = object ["ngrok_message" .= x] server :: TVar TopicResult -> IO () server t = void $ concurrently ngrok $ do@@ -141,6 +119,6 @@ let topic = responseBody ^? key "topic" lift $ case topic of Just (String s) -> record (Just s) t- Nothing -> record Nothing t+ _ -> record Nothing t r <- lift $ readTVarIO t text $ r & (pack . show)
src/Shelduck/Configuration.hs view
@@ -3,5 +3,8 @@ pollTime :: Int pollTime = 100000 +retryWait :: Int+retryWait = 10000000+ polls :: Int polls = 2000
src/Shelduck/IntercomDefinitions.hs view
@@ -42,6 +42,9 @@ userId :: T.Text userId = "55b26822ce97179e52001334" +userEmail :: T.Text+userEmail = "bob+testuser17@intercom.io"+ userType :: T.Text userType = "user" @@ -72,9 +75,19 @@ tagName :: T.Text tagName = "foo" +eventName :: T.Text+eventName = "shelduck-test-event"+ run :: TVar TopicResult -> IO () run t = void $ do threadDelay 5000000++ options <- opts+ eventTimestamp <- round <$> getPOSIXTime+ go $ blank & requestEndpoint .~ "https://api.intercom.io/events"+ & requestOpts .~ options+ & requestParameters .~ object ["email" .= userEmail, "event_name" .= eventName, "created_at" .= (eventTimestamp :: Integer)]+ & requestTopic .~ "event.created" options <- opts contactResp <- go $ blank & requestEndpoint .~ "https://api.intercom.io/contacts"
src/Shelduck/Internal.hs view
@@ -1,19 +1,49 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-} module Shelduck.Internal where import Control.Concurrent import Control.Concurrent.STM.TVar+import Control.Lens hiding ((.=))+import Control.Monad import Control.Monad.STM+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader import Data.Aeson+import qualified Data.ByteString.Lazy.Char8 as BL import Data.Text+import qualified Network.Wreq as W import Shelduck.Configuration import System.Environment +data WebhookRequest = WebhookRequest {+ _requestEndpoint :: Text,+ _requestOpts :: W.Options,+ _requestParameters :: Value,+ _requestTopic :: Text+}++blank :: WebhookRequest+blank = WebhookRequest mempty W.defaults (object []) mempty++$(makeLenses ''WebhookRequest)++type TopicResult = Maybe Text+type RequestData = (WebhookRequest, Text, Text)+ record :: Maybe Text -> TVar (Maybe Text) -> IO () record t r = atomically $ writeTVar r t +doRetry :: RequestData -> (RequestData -> ReaderT (TVar TopicResult) IO b) -> ReaderT (TVar TopicResult) IO ()+doRetry r c = ask >>=+ \t -> do+ currentResult <- lift $ atomically (readTVar t)+ case currentResult of+ Nothing -> lift (info "Retrying...") >> c r >> void (lift $ threadDelay retryWait)+ _ -> return ()+ pollingIO :: Int -> TVar a -> (TVar a -> IO Bool) -> IO b -> IO (Int, b) pollingIO c t x i = temporaryFailure >>= \f -> if f then tryAgain else finish where tryAgain = threadDelay pollTime >> pollingIO (c - 1) t x i@@ -38,3 +68,6 @@ instance ToJSON SlackTestReport where toJSON SlackTestReport{..} = object ["text" .= mconcat ["Topic: ", topic, ", pass: ", (pack . show) pass]]++info :: Value -> IO ()+info = BL.putStrLn . encode
src/Shelduck/Keen.hs view
@@ -6,16 +6,13 @@ import Control.Lens hiding ((.=)) import Control.Monad (void)-import Control.Monad.Trans.Class-import Control.Monad.Trans.Maybe import Data.Aeson import qualified Data.ByteString.Lazy as L import Data.Text-import Data.Traversable import Shelduck.Internal import qualified Network.Wreq as W-import System.Environment +opts :: W.Options opts = W.defaults & W.header "Accept" .~ ["application/json"] & W.header "Content-Type" .~ ["application/json"]
src/Shelduck/Templating.hs view
@@ -2,7 +2,6 @@ import Data.Text import Data.Text.Lazy (toStrict)-import qualified Data.Text.Lazy.IO as TL import Data.UUID import Data.UUID.V4 import Text.Hastache@@ -13,3 +12,4 @@ u <- fmap toString nextRandom fmap toStrict (hastacheStr defaultConfig t (mkStrContext $ c u)) where c r "random" = MuVariable r+ c _ _ = MuNothing
test/Tests.hs view
@@ -4,25 +4,19 @@ import Control.Concurrent.STM import Control.Lens+import Control.Monad+import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import Data.Aeson import Data.Maybe-import Data.Text import qualified Network.Wreq as W import Shelduck import Shelduck.Internal-import Shelduck.Templating import System.Environment import Test.Hspec-import Text.Regex main :: IO () main = hspec $ do- describe "templating" $- it "substitutes random numbers at runtime" $ do- let regex = mkRegex "{\"foo\":\"bar[0-9a-zA-Z\\-]+\"}"- t <- template "{\"foo\":\"bar{{random}}\"}"- matchRegex regex (unpack t) `shouldBe` Just [] describe "reading results" $ do it "detects success" $ do r <- newTVarIO (Just "foo") :: IO (TVar TopicResult)@@ -42,6 +36,23 @@ handler = doHandle req result <- runReaderT handler r result `shouldBe` False+ describe "retries" $ do+ it "works" $ do+ r <- newTVarIO Nothing :: IO (TVar TopicResult)+ let requestData = (blank, mempty, mempty)+ continue :: RequestData -> ReaderT (TVar TopicResult) IO ()+ continue _ = void $ lift (atomically $ writeTVar r (Just "done"))+ runReaderT (doRetry requestData continue) r+ result <- readTVarIO r+ result `shouldBe` Just "done"+ it "does not retry unnecessarily" $ do+ r <- newTVarIO (Just "untouched") :: IO (TVar TopicResult)+ let requestData = (blank, mempty, mempty)+ continue :: RequestData -> ReaderT (TVar TopicResult) IO ()+ continue _ = void $ lift (atomically $ writeTVar r (Just "done"))+ runReaderT (doRetry requestData continue) r+ result <- readTVarIO r+ result `shouldBe` Just "untouched" describe "writing results" $ it "works" $ do r <- newTVarIO Nothing :: IO (TVar TopicResult)