Add back legacy mismi-sqs module

mismi-core/src/Mismi/Control.hs

@@ -31,6 +31,7 @@ module Mismi.Control (
   , setRetry
   , configureRetries
   , handleServiceError
+  , handle400Error
   , withRetries
   , withRetriesOf
   , throwOrRetry
@@ -359,6 +360,21 @@ handleServiceError f pass action =
         throwM e
 
 
+handle400Error :: ErrorCode -> AWS a -> AWS (Maybe a)
+handle400Error code action =
+  let
+    check :: ServiceError -> Bool
+    check er =
+      let
+        httpStatus = _serviceStatus er == HTTP.status400
+        codeCheck = _serviceCode er == code
+      in
+        httpStatus && codeCheck
+  in
+    handleServiceError check (const Nothing) (Just <$> action)
+
+
+
 timeoutAWS :: Int -> AWS a -> AWS (Maybe a)
 timeoutAWS i r = do
   e <- ask

mismi-secretsmanager/src/Mismi/SecretsManager/Commands.hs

@@ -66,21 +66,8 @@ writeString path token string = do
 
 handleExists :: AWS a -> AWS (Maybe a)
 handleExists =
-  handleError "ResourceExists"
+  handle400Error "ResourceExists"
 
 handleMissing :: AWS a -> AWS (Maybe a)
 handleMissing =
-  handleError "ResourceNotFound"
-
-handleError :: ErrorCode -> AWS a -> AWS (Maybe a)
-handleError code action =
-  let
-    check :: ServiceError -> Bool
-    check er =
-      let
-        httpStatus = _serviceStatus er == HTTP.status400
-        codeCheck = _serviceCode er == code
-      in
-        httpStatus && codeCheck
-  in
-    handleServiceError check (const Nothing) (Just <$> action)
+  handle400Error "ResourceNotFound"

mismi-sqs/.ghci

@@ -0,0 +1 @@
+../framework/ghci

mismi-sqs/CHANGELOG.md

@@ -0,0 +1 @@
+../CHANGELOG.md

mismi-sqs/LICENSE

@@ -0,0 +1 @@
+../LICENSE

mismi-sqs/README.md

@@ -0,0 +1,2 @@
+sqs
+---

mismi-sqs/mismi-sqs.cabal

@@ -0,0 +1,97 @@
+version: 0.0.3
+
+name:
+  mismi-sqs
+author:
+  Nick Hibberd
+maintainer:
+  Nick Hibberd <[email protected]>
+homepage:
+  https://github.com/nhibberd/mismi
+bug-reports:
+  https://github.com/nhibberd/mismi/issues
+synopsis:
+  AWS Library
+description:
+  mismi-sqs is a library that provides a set of common and useful
+  operations on top of AWS SQS.
+category:
+  AWS
+license:
+  BSD3
+license-file:
+  LICENSE
+cabal-version:
+  >= 1.8
+build-type:
+  Simple
+tested-with:
+    GHC == 8.2.2
+  , GHC == 8.4.3
+  , GHC == 8.6.3
+extra-source-files:
+  CHANGELOG.md
+
+library
+  build-depends:
+      base                            >= 3          && < 5
+    , mismi-core                      == 0.0.3.*
+    , mismi-kernel                    == 0.0.3.*
+    , mismi-p                         == 0.0.3.*
+    , template-haskell
+    , amazonka                        >= 1.5        && < 1.7
+    , amazonka-core                   >= 1.5        && < 1.7
+    , amazonka-sqs                    >= 1.5        && < 1.7
+    , exceptions                      >= 0.7        && < 0.11
+    , text                            == 1.2.*
+    , transformers                    >= 0.3.1      && < 0.6
+    , transformers-bifunctors         >= 0.1        && < 1
+    , lens                            >= 4.8        && < 4.18
+    , unordered-containers            >= 0.2.5      && < 0.3
+
+  ghc-options:
+    -Wall
+
+  hs-source-dirs:
+    src
+
+  exposed-modules:
+    Mismi.SQS.Amazonka
+    Mismi.SQS.Commands
+    Mismi.SQS.Data
+    Mismi.SQS.Error
+
+test-suite test-io
+  type:
+    exitcode-stdio-1.0
+
+  main-is:
+    test-io.hs
+
+  ghc-options:
+    -Wall -threaded -O2
+
+  hs-source-dirs:
+    test
+
+  other-modules:
+    Test.Mismi.SQS.Gen
+    Test.IO.Mismi.SQS.Commands
+    Test.IO.Mismi.SQS.Util
+
+  build-depends:
+      base
+    , mismi-kernel                    == 0.0.3.*
+    , mismi-core                      == 0.0.3.*
+    , mismi-core-test                 == 0.0.3.*
+    , mismi-sqs
+    , mismi-p                         == 0.0.3.*
+    , mmorph                          >= 1.0        && < 1.2
+    , exceptions                      >= 0.7        && < 0.11
+    , hedgehog
+    , lens                            >= 4.8        && < 4.18
+    , mtl                             >= 2.1        && < 2.3
+    , resourcet                       >= 1.1        && < 1.3
+    , text                            == 1.2.*
+    , time                            >= 1.4        && < 1.10
+    , transformers                    >= 0.3.1      && < 0.6

mismi-sqs/src/Mismi/SQS/Amazonka.hs

@@ -0,0 +1,8 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+module Mismi.SQS.Amazonka (
+    module AWS
+  ) where
+
+import           Mismi.Amazonka as AWS hiding (Document)
+
+import           Network.AWS.SQS as AWS

mismi-sqs/src/Mismi/SQS/Commands.hs

@@ -0,0 +1,119 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Mismi.SQS.Commands (
+    onQueue
+  , createQueue
+  , createQueueRaw
+  , deleteQueue
+  , readMessages
+  , readMessagesWithAttributes
+  , writeMessage
+  , deleteMessage
+  ) where
+
+import           Control.Lens ((^.), (.~))
+import           Control.Exception.Lens (handling)
+import           Control.Monad.Catch (throwM)
+
+import qualified Data.List as List
+import qualified Data.Text as T
+import qualified Data.HashMap.Strict as M
+
+import           Mismi (AWS, fromMismiRegion)
+import           Mismi.Control (handle400Error)
+import           Mismi.SQS.Amazonka as A hiding (createQueue, deleteQueue, deleteMessage)
+import qualified Mismi.SQS.Amazonka as A
+import           Mismi.SQS.Data
+import           Mismi.SQS.Error (SQSError (..))
+
+import           P
+
+
+readMessages :: QueueUrl -> Maybe MessageCount -> Maybe WaitTime -> AWS [A.Message]
+readMessages q c w = do
+  res <- A.send $ A.receiveMessage (renderQueueUrl q)
+    & A.rmMaxNumberOfMessages .~  fmap messageCount c
+    & A.rmWaitTimeSeconds .~ fmap waitTime w
+  pure $ res ^. rmrsMessages
+
+readMessagesWithAttributes :: QueueUrl -> Maybe MessageCount -> Maybe WaitTime -> [Text] -> AWS [A.Message]
+readMessagesWithAttributes q c w keys = do
+  res <- A.send $ A.receiveMessage (renderQueueUrl q)
+    & A.rmMaxNumberOfMessages .~ fmap messageCount c
+    & A.rmWaitTimeSeconds .~ fmap waitTime w
+    & A.rmMessageAttributeNames .~ keys
+  pure $ res ^. rmrsMessages
+
+-- | Create a queue, which may be in a different region than our global/current one (which will be ignored)
+onQueue :: Queue -> Maybe Visibility -> (QueueUrl -> AWS a) -> AWS a
+onQueue (Queue q r) v action =
+  within (fromMismiRegion r) (action =<< createQueue q v)
+
+createQueueRaw :: QueueName -> Maybe Visibility -> AWS QueueUrl
+createQueueRaw q vis = do
+  let
+    visbility v =
+      (A.QANVisibilityTimeout, T.pack . show $ visibility v)
+
+  res <- handleExists q . A.send $ A.createQueue (renderQueueName q)
+    & A.cqAttributes .~ (M.fromList . maybeToList $ fmap visbility vis)
+  maybe
+    (throwM . Invariant $ "Failed to create new queue: " <> (T.pack . show) q)
+    (pure . QueueUrl)
+    (res ^. cqrsQueueURL)
+
+-- If queue already exists (and has different VisibilityTimeout)
+handleExists :: QueueName -> AWS A.CreateQueueResponse -> AWS A.CreateQueueResponse
+handleExists q =
+  handling _QueueNameExists $ \_ ->
+    -- Get existing queue (using default parameters)
+    send $ A.createQueue (renderQueueName q)
+
+-- | Returns the QueueUrl if the Queue already exists and if it doesn't.
+-- calls `createQueueRaw` to create the Queue.
+createQueue :: QueueName -> Maybe Visibility -> AWS QueueUrl
+createQueue q v = do
+  let
+    handler =
+      handle400Error "AWS.SimpleQueueService.NonExistentQueue"
+
+  res <- handler . A.send $
+    listQueues
+      & lqQueueNamePrefix .~ Just (renderQueueName q)
+
+  case res of
+    Nothing ->
+      createQueue q v
+
+    Just res' ->
+      maybe
+        (createQueueRaw q v)
+        (pure . QueueUrl)
+        (listToMaybe . List.filter (isMatchingQueueName q) $ res' ^. lqrsQueueURLs)
+
+isMatchingQueueName :: QueueName -> Text -> Bool
+isMatchingQueueName q url =
+  case T.split (== '/') url of
+    [] ->
+      False
+    xs ->
+      List.last xs == renderQueueName q
+
+deleteQueue :: QueueUrl -> AWS ()
+deleteQueue =
+  void . send . A.deleteQueue . renderQueueUrl
+
+writeMessage :: QueueUrl -> Text -> AWS (MessageId)
+writeMessage q m = do
+  res <- send $ A.sendMessage (renderQueueUrl q) m
+  maybe
+    (throwM . Invariant $ "Failed to parse MessageId")
+    (pure . MessageId)
+    (res ^. smrsMessageId)
+
+deleteMessage :: QueueUrl -> A.Message -> AWS ()
+deleteMessage q m = do
+   i <- maybe (throwM . Invariant $ "MessageId cannot be Nothing") pure (m ^. mReceiptHandle)
+   void . send $ A.deleteMessage (renderQueueUrl q) i

mismi-sqs/src/Mismi/SQS/Data.hs

@@ -0,0 +1,59 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Mismi.SQS.Data (
+    QueueName (..)
+  , Queue (..)
+  , QueueUrl (..)
+  , MessageId (..)
+
+  , MessageCount (..)
+  , Visibility (..)
+  , WaitTime (..)
+  ) where
+
+import           Mismi.Kernel.Data (MismiRegion)
+
+import           P
+
+
+-- Queue names are limited to 80 characters. Alphanumeric characters
+-- plus hyphens (-) and underscores (_) are allowed. Queue names must
+-- be unique within an AWS account. After you delete a queue, you can
+-- reuse the queue name.
+newtype QueueName =
+  QueueName {
+      renderQueueName :: Text
+    } deriving (Eq, Show)
+
+data Queue =
+  Queue {
+      queueName :: QueueName
+    , queueRegion :: MismiRegion
+    } deriving (Eq, Show)
+
+newtype QueueUrl =
+  QueueUrl {
+      renderQueueUrl :: Text
+    } deriving (Eq, Show)
+
+newtype MessageId =
+  MessageId {
+      renderMessageId :: Text
+    } deriving (Eq, Show)
+
+
+newtype MessageCount =
+  MessageCount {
+      messageCount :: Int
+    } deriving (Eq, Show)
+
+newtype Visibility =
+  Visibility {
+      visibility :: Int
+    } deriving (Eq, Show)
+
+newtype WaitTime =
+  WaitTime {
+      waitTime :: Int
+    } deriving (Eq, Show)

mismi-sqs/src/Mismi/SQS/Error.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Mismi.SQS.Error (
+    SQSError(..)
+  , sqsErrorRender
+  ) where
+
+import           Control.Exception.Base (Exception)
+
+import qualified Data.Text as T
+import           Data.Typeable (Typeable)
+
+import           P
+
+data SQSError =
+    Invariant Text
+    deriving (Typeable)
+
+instance Exception SQSError
+
+instance Show SQSError where
+  show = T.unpack . sqsErrorRender
+
+sqsErrorRender :: SQSError -> Text
+sqsErrorRender (Invariant e) =
+  "[Mismi internal error] - " <> e