Merge pull request #2 from haskell-works/newhoggy/initial-project

Initial project

.github/workflows/ci.yml

@@ -0,0 +1,67 @@
+name: Binaries
+
+defaults:
+  run:
+    shell: bash
+
+on:
+  push:
+    branches:
+      - main
+  pull_request:
+
+jobs:
+  build:
+    runs-on: ${{ matrix.os }}
+
+    strategy:
+      fail-fast: false
+      matrix:
+        ghc: ["9.6.6"]
+        os: [ubuntu-latest]
+
+    steps:
+      - uses: actions/checkout@v2
+
+      - uses: haskell/actions/setup@v2
+        id: setup-haskell
+        with:
+          ghc-version: ${{ matrix.ghc }}
+          cabal-version: 3.12.1.0
+
+      - name: Configure project
+        run: |
+          cabal configure --enable-tests --enable-benchmarks
+          cabal build all --dry-run
+
+      - name: Record dependencies
+        run: |
+          cat dist-newstyle/cache/plan.json | jq -r '."install-plan"[].id' | sort | uniq > dependencies.txt
+          date +"%Y-%m-%d" > date.txt
+  
+      - name: Cache cabal store
+        uses: actions/cache/restore@v4
+        with:
+          path: ${{ steps.setup-haskell.outputs.cabal-store }}
+          key: |
+            cache-${{ env.CACHE_VERSION }}-${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('dependencies.txt') }}-${{ hashFiles('date.txt') }}
+          restore-keys: |
+            cache-${{ env.CACHE_VERSION }}-${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('dependencies.txt') }}-${{ hashFiles('date.txt') }}
+            cache-${{ env.CACHE_VERSION }}-${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('dependencies.txt') }}
+            cache-${{ env.CACHE_VERSION }}-${{ runner.os }}-${{ matrix.ghc }}
+
+      - name: Build
+        run: cabal build all
+
+      - name: Cache Cabal store
+        uses: actions/cache/save@v4
+        with:
+          path: ${{ steps.setup-haskell.outputs.cabal-store }}
+          key: |
+            cache-${{ env.CACHE_VERSION }}-${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('dependencies.txt') }}-${{ hashFiles('date.txt') }}
+    
+      - name: Test
+        env:
+          LOCALSTACK_AUTH_TOKEN: ${{ secrets.LOCALSTACK_AUTH_TOKEN }}
+        run: |
+          cabal test all --enable-tests --enable-benchmarks

LICENSE

@@ -0,0 +1,28 @@
+BSD 3-Clause License
+
+Copyright (c) 2024, haskell-works
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice, this
+   list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright notice,
+   this list of conditions and the following disclaimer in the documentation
+   and/or other materials provided with the distribution.
+
+3. Neither the name of the copyright holder nor the names of its
+   contributors may be used to endorse or promote products derived from
+   this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

app/App/AWS/Env.hs

@@ -0,0 +1,88 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+
+module App.AWS.Env
+  ( awsLogger
+  , mkEnv
+  , newAwsLogger
+  , setEnvEndpoint
+  ) where
+
+import App.Show                     (tshow)
+import Control.Concurrent           (myThreadId)
+import Control.Monad                (when, forM_)
+import Data.ByteString              (ByteString)
+import Data.ByteString.Builder      (toLazyByteString)
+import Data.Function                ((&))
+import Data.Generics.Product.Any    (the)
+import Lens.Micro                   ((.~), (%~))
+import Network.HTTP.Client          (HttpException (..), HttpExceptionContent (..))
+
+import qualified Amazonka                   as AWS
+import qualified Data.ByteString            as BS
+import qualified Data.ByteString.Lazy       as L
+import qualified Data.ByteString.Lazy       as LBS
+import qualified Data.ByteString.Lazy.Char8 as LC8
+import qualified Data.Text.Encoding         as T
+import qualified App.Console                as CIO
+import qualified System.IO                  as IO
+
+setEnvEndpoint :: Maybe (ByteString, Int, Bool) -> IO AWS.Env -> IO AWS.Env
+setEnvEndpoint mHostEndpoint getEnv = do
+  env <- getEnv
+  case mHostEndpoint of
+    Just (host, port, ssl) ->
+      pure $ env
+        & the @"overrides" .~ \svc -> do
+            svc & the @"endpoint" %~ \mkEndpoint region -> do
+              mkEndpoint region
+                & the @"host" .~ host
+                & the @"port" .~ port
+                & the @"secure" .~ ssl
+    Nothing -> pure env
+
+mkEnv :: AWS.Region -> (AWS.LogLevel -> LBS.ByteString -> IO ()) -> IO AWS.Env
+mkEnv region lg = do
+  lgr <- newAwsLogger lg
+  discoveredEnv <- AWS.newEnv AWS.discover
+
+  pure discoveredEnv
+    { AWS.logger = lgr
+    , AWS.region = region
+    , AWS.retryCheck = retryPolicy 5
+    }
+
+newAwsLogger :: Monad m => (AWS.LogLevel -> LBS.ByteString -> IO ()) -> m AWS.Logger
+newAwsLogger lg = return $ \y b ->
+  let lazyMsg = toLazyByteString b
+  in case L.toStrict lazyMsg of
+      msg | BS.isInfixOf "404 Not Found" msg    -> lg AWS.Debug lazyMsg
+      msg | BS.isInfixOf "304 Not Modified" msg -> lg AWS.Debug lazyMsg
+      _                                         -> lg y lazyMsg
+
+retryPolicy :: Int -> Int -> AWS.HttpException -> Bool
+retryPolicy maxNum attempt ex = (attempt <= maxNum) && shouldRetry ex
+
+shouldRetry :: AWS.HttpException -> Bool
+shouldRetry ex = case ex of
+  HttpExceptionRequest _ ctx -> case ctx of
+    ResponseTimeout          -> True
+    ConnectionTimeout        -> True
+    ConnectionFailure _      -> True
+    InvalidChunkHeaders      -> True
+    ConnectionClosed         -> True
+    InternalException _      -> True
+    NoResponseDataReceived   -> True
+    ResponseBodyTooShort _ _ -> True
+    _                        -> False
+  _ -> False
+
+awsLogger :: Maybe AWS.LogLevel -> AWS.LogLevel -> LC8.ByteString -> IO ()
+awsLogger maybeConfigLogLevel msgLogLevel message =
+  forM_ maybeConfigLogLevel $ \configLogLevel ->
+    when (msgLogLevel <= configLogLevel) do
+      threadId <- myThreadId
+      CIO.hPutStrLn IO.stderr $ "[" <> tshow msgLogLevel <> "] [tid: " <> tshow threadId <> "]"  <> text
+  where text = T.decodeUtf8 $ LBS.toStrict message

app/App/Cli/Options.hs

@@ -0,0 +1,97 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings     #-}
+
+module App.Cli.Options where
+
+import           App.Options
+import           Control.Applicative
+import           Data.ByteString     (ByteString)
+
+import qualified Amazonka.Data       as AWS
+import qualified App.Cli.Types       as CLI
+import qualified Data.Text           as T
+import qualified Options.Applicative as OA
+
+opts :: OA.ParserInfo CLI.Cmd
+opts = OA.info (pCmds <**> OA.helper) $ mconcat
+  [ OA.fullDesc
+  , OA.header $ mconcat
+    [ "rds-data"
+    ]
+  ]
+
+pCmds :: OA.Parser CLI.Cmd
+pCmds =
+  asum
+    [ subParser "up"
+        $ OA.info (CLI.CmdOfUpCmd <$> pUpCmd)
+        $ OA.progDesc "Up command."
+    , subParser "down"
+        $ OA.info (CLI.CmdOfDownCmd <$> pDownCmd)
+        $ OA.progDesc "Down command."
+    , subParser "local-stack"
+        $ OA.info (CLI.CmdOfLocalStackCmd <$> pLocalStackCmd)
+        $ OA.progDesc "Launch a local-stack RDS cluster."
+    ]
+
+pUpCmd :: OA.Parser CLI.UpCmd
+pUpCmd =
+  CLI.UpCmd
+    <$> do  OA.strOption $ mconcat
+              [ OA.long "resource-arn"
+              , OA.help "Resource ARN"
+              , OA.metavar "ARN"
+              ]
+    <*> do  OA.strOption $ mconcat
+              [ OA.long "secret-arn"
+              , OA.help "Secret ARN"
+              , OA.metavar "ARN"
+              ]
+    <*> do  OA.strOption $ mconcat
+              [ OA.long "migration-file"
+              , OA.help "Migration File"
+              , OA.metavar "FILE"
+              ]
+
+pDownCmd :: OA.Parser CLI.DownCmd
+pDownCmd =
+  CLI.DownCmd
+    <$> do  OA.strOption $ mconcat
+              [ OA.long "resource-arn"
+              , OA.help "Resource ARN"
+              , OA.metavar "ARN"
+              ]
+    <*> do  OA.strOption $ mconcat
+              [ OA.long "secret-arn"
+              , OA.help "Secret ARN"
+              , OA.metavar "ARN"
+              ]
+    <*> do  OA.strOption $ mconcat
+              [ OA.long "migration-file"
+              , OA.help "Migration File"
+              , OA.metavar "FILE"
+              ]
+
+pLocalStackCmd :: OA.Parser CLI.LocalStackCmd
+pLocalStackCmd =
+  pure CLI.LocalStackCmd
+
+parseEndpoint :: OA.Parser (ByteString, Int, Bool)
+parseEndpoint =
+  (,,)
+    <$> do  OA.option (OA.eitherReader (AWS.fromText . T.pack)) $ mconcat
+              [ OA.long "host-name-override"
+              , OA.help "Override the host name (default: s3.amazonaws.com)"
+              , OA.metavar "HOST_NAME"
+              ]
+    <*> do  OA.option OA.auto $ mconcat
+              [ OA.long "host-port-override"
+              , OA.help "Override the host port"
+              , OA.metavar "HOST_PORT"
+              ]
+    <*> do  OA.option OA.auto $ mconcat
+              [ OA.long "host-ssl-override"
+              , OA.help "Override the host SSL"
+              , OA.metavar "HOST_SSL"
+              ]

app/App/Cli/Run.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE BlockArguments        #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase            #-}
+
+module App.Cli.Run
+  ( runCmd
+  ) where
+
+import           App.Cli.Run.BatchExecuteStatement
+import           App.Cli.Run.Down
+import           App.Cli.Run.Example
+import           App.Cli.Run.ExecuteStatement
+import           App.Cli.Run.LocalStack
+import           App.Cli.Run.Up
+
+import qualified App.Cli.Types                     as CLI
+
+runCmd :: CLI.Cmd -> IO ()
+runCmd = \case
+  CLI.CmdOfBatchExecuteStatementCmd cmd -> runBatchExecuteStatementCmd cmd
+  CLI.CmdOfDownCmd cmd                  -> runDownCmd cmd
+  CLI.CmdOfExampleCmd cmd               -> runExampleCmd cmd
+  CLI.CmdOfExecuteStatementCmd cmd      -> runExecuteStatementCmd cmd
+  CLI.CmdOfLocalStackCmd cmd            -> runLocalStackCmd cmd
+  CLI.CmdOfUpCmd cmd                    -> runUpCmd cmd

app/App/Cli/Run/BatchExecuteStatement.hs

@@ -0,0 +1,12 @@
+{-# LANGUAGE BlockArguments        #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module App.Cli.Run.BatchExecuteStatement
+  ( runBatchExecuteStatementCmd
+  ) where
+
+import qualified App.Cli.Types as CLI
+
+runBatchExecuteStatementCmd :: CLI.BatchExecuteStatementCmd -> IO ()
+runBatchExecuteStatementCmd _ = pure ()