hw-uri 0.1.1.4 → 0.1.1.5

raw patch · 12 files changed

+396/−38 lines, 12 filesdep +antiope-optparse-applicativedep +hw-primdep +optparse-applicativedep ~antiope-coredep ~antiope-s3new-component:exe:hw-uriPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependencies added: antiope-optparse-applicative, hw-prim, optparse-applicative, unliftio-core

Dependency ranges changed: antiope-core, antiope-s3

API changes (from Hackage documentation)

Files

• app/App/Aws/Logger.hs +25/−0
• app/App/Commands.hs +15/−0
• app/App/Commands/Cp.hs +81/−0
• app/App/Commands/LsPrefix.hs +72/−0
• app/App/Commands/Types.hs +26/−0
• app/App/Show.hs +10/−0
• app/Main.hs +11/−0
• hw-uri.cabal +63/−35
• src/HaskellWorks/Data/Uri/IO/File.hs +48/−3
• src/HaskellWorks/Data/Uri/IO/Lazy.hs +11/−0
• src/HaskellWorks/Data/Uri/Internal/List.hs +5/−0
• test/HaskellWorks/Data/Uri/Internal/ListSpec.hs +29/−0

@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}++module App.Aws.Logger+  ( awsLogger+  ) where++import Antiope.Env        (LogLevel (..))+import App.Show+import Control.Concurrent (myThreadId)+import Control.Monad+import Data.Semigroup     ((<>))++import qualified Data.ByteString.Lazy       as LBS+import qualified Data.ByteString.Lazy.Char8 as LC8+import qualified Data.Text.Encoding         as T+import qualified Data.Text.IO               as TIO+import qualified System.IO                  as IO++awsLogger :: Maybe LogLevel -> LogLevel -> LC8.ByteString -> IO ()+awsLogger maybeConfigLogLevel msgLogLevel message =+  forM_ maybeConfigLogLevel $ \configLogLevel ->+    when (msgLogLevel <= configLogLevel) $ do+      threadId <- myThreadId+      TIO.hPutStrLn IO.stderr $ "[" <> tshow msgLogLevel <> "] [tid: " <> tshow threadId <> "]"  <> text+  where text = T.decodeUtf8 $ LBS.toStrict message

@@ -0,0 +1,15 @@+module App.Commands where++import App.Commands.Cp+import App.Commands.LsPrefix+import Data.Semigroup        ((<>))+import Options.Applicative++commands :: Parser (IO ())+commands = commandsGeneral++commandsGeneral :: Parser (IO ())+commandsGeneral = subparser $ mempty+  <>  commandGroup "Commands:"+  <>  cmdCp+  <>  cmdLsPrefix

@@ -0,0 +1,81 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}++module App.Commands.Cp+  ( cmdCp+  ) where++import Antiope.Core                   (Region (..))+import Antiope.Env                    (mkEnv)+import Antiope.Options.Applicative+import Control.Lens+import Control.Monad.Except+import Control.Monad.Trans.Resource   (runResourceT)+import Data.Generics.Product.Any+import Data.Semigroup                 ((<>))+import HaskellWorks.Data.Uri.Location+import HaskellWorks.Data.Uri.UriError (displayUriError)+import Options.Applicative            hiding (columns)++import qualified App.Aws.Logger                as AWS+import qualified App.Commands.Types            as Z+import qualified Data.Text                     as T+import qualified Data.Text.IO                  as TIO+import qualified HaskellWorks.Data.Uri.IO.Lazy as URI+import qualified System.IO                     as IO+import qualified System.IO.Unsafe              as IO++runCp :: Z.CpOptions -> IO ()+runCp opts = do+  let input       = opts ^. the @"input"+  let output      = opts ^. the @"output"+  let region      = opts ^. the @"region"+  let awsLogLevel = opts ^. the @"awsLogLevel"++  envAws <- IO.unsafeInterleaveIO $ mkEnv region (AWS.awsLogger awsLogLevel)++  result <- runResourceT . runExceptT $ do+    lbsResult <- URI.readResource envAws input++    case lbsResult of+      Right lbs -> void $ URI.writeResource envAws output lbs+      Left msg  -> return ()++    return ()++  case result of+    Right _  -> return ()+    Left msg -> TIO.hPutStrLn IO.stderr (displayUriError msg)++optsCp :: Parser Z.CpOptions+optsCp = Z.CpOptions+  <$> option (maybeReader (toLocation . T.pack))+        (   long "input"+        <>  short 'i'+        <>  help "Input location"+        <>  metavar "LOCATION"+        )+  <*> option (maybeReader (toLocation . T.pack))+        (   long "output"+        <>  short 'o'+        <>  help "Output location"+        <>  metavar "LOCATION"+        )+  <*> option auto+      (  long "region"+      <> metavar "AWS_REGION"+      <> showDefault <> value Oregon+      <> help "The AWS region in which to operate"+      )+  <*> optional+      ( option autoText+        (   long "aws-log-level"+        <>  help "AWS Log Level.  One of (Error, Info, Debug, Trace)"+        <>  metavar "AWS_LOG_LEVEL"+        )+      )++cmdCp :: Mod CommandFields (IO ())+cmdCp = command "cp"  $ flip info idm $ runCp <$> optsCp

@@ -0,0 +1,72 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}++module App.Commands.LsPrefix+  ( cmdLsPrefix+  ) where++import Antiope.Core                   (Region (..))+import Antiope.Env                    (mkEnv)+import Antiope.Options.Applicative+import App.Show+import Control.Lens+import Control.Monad.Except+import Control.Monad.Trans.Resource   (runResourceT)+import Data.Generics.Product.Any+import Data.Semigroup                 ((<>))+import HaskellWorks.Data.Uri.Location+import HaskellWorks.Data.Uri.UriError (displayUriError)+import Options.Applicative            hiding (columns)++import qualified App.Aws.Logger                as AWS+import qualified App.Commands.Types            as Z+import qualified Data.Text                     as T+import qualified Data.Text.IO                  as TIO+import qualified HaskellWorks.Data.Uri.IO.Lazy as URI+import qualified System.IO                     as IO+import qualified System.IO.Unsafe              as IO++runLsPrefix :: Z.LsPrefixOptions -> IO ()+runLsPrefix opts = do+  let prefix       = opts ^. the @"prefix"+  let region      = opts ^. the @"region"+  let awsLogLevel = opts ^. the @"awsLogLevel"++  envAws <- IO.unsafeInterleaveIO $ mkEnv region (AWS.awsLogger awsLogLevel)++  result <- runResourceT . runExceptT $ do+    locations <- URI.listResourcePrefix envAws prefix+    forM_ locations $ \location -> liftIO $ TIO.putStrLn (tshow location)++    return ()++  case result of+    Right _  -> return ()+    Left msg -> TIO.hPutStrLn IO.stderr (displayUriError msg)++optsLsPrefix :: Parser Z.LsPrefixOptions+optsLsPrefix = Z.LsPrefixOptions+  <$> option (maybeReader (toLocation . T.pack))+        (   long "prefix"+        <>  short 'p'+        <>  help "Prefix location"+        <>  metavar "LOCATION"+        )+  <*> option auto+      (  long "region"+      <> metavar "AWS_REGION"+      <> showDefault <> value Oregon+      <> help "The AWS region in which to operate"+      )+  <*> optional+      ( option autoText+        (   long "aws-log-level"+        <>  help "AWS Log Level.  One of (Error, Info, Debug, Trace)"+        <>  metavar "AWS_LOG_LEVEL"+        )+      )++cmdLsPrefix :: Mod CommandFields (IO ())+cmdLsPrefix = command "ls-prefix"  $ flip info idm $ runLsPrefix <$> optsLsPrefix

@@ -0,0 +1,26 @@+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE DuplicateRecordFields #-}++module App.Commands.Types+  ( CpOptions(..)+  , LsPrefixOptions(..)+  ) where++import Antiope.Env                    (Region)+import GHC.Generics+import HaskellWorks.Data.Uri.Location++import qualified Antiope.Env as AWS++data CpOptions = CpOptions+  { input       :: Location+  , output      :: Location+  , region      :: Region+  , awsLogLevel :: Maybe AWS.LogLevel+  } deriving (Eq, Show, Generic)++data LsPrefixOptions = LsPrefixOptions+  { prefix      :: Location+  , region      :: Region+  , awsLogLevel :: Maybe AWS.LogLevel+  } deriving (Eq, Show, Generic)

@@ -0,0 +1,10 @@+module App.Show+  ( tshow+  ) where++import Data.Text (Text)++import qualified Data.Text as T++tshow :: Show a => a -> Text+tshow = T.pack . show

@@ -0,0 +1,11 @@+module Main where++import App.Commands+import Control.Monad+import Data.Semigroup      ((<>))+import Options.Applicative++main :: IO ()+main = join $ customExecParser+  (prefs $ showHelpOnEmpty <> showHelpOnError)+  (info (commands <**> helper) idm)

@@ -1,7 +1,7 @@-cabal-version:          2.2+cabal-version:          2.4  name:                   hw-uri-version:                0.1.1.4+version:                0.1.1.5 synopsis:               Supports IO on URIs description:            Supports IO on URIs. homepage:               https://github.com/haskell-works/hw-uri@@ -23,8 +23,9 @@ common amazonka                       { build-depends: amazonka                       >= 1.6.1      && < 1.7    } common amazonka-core                  { build-depends: amazonka-core                  >= 1.6.1      && < 1.7    } common amazonka-s3                    { build-depends: amazonka-s3                    >= 1.6.1      && < 1.7    }-common antiope-core                   { build-depends: antiope-core                   >= 7.3.3      && < 8      }-common antiope-s3                     { build-depends: antiope-s3                     >= 7.3.3      && < 8      }+common antiope-core                   { build-depends: antiope-core                   >= 7.4.2      && < 8      }+common antiope-s3                     { build-depends: antiope-s3                     >= 7.4.2      && < 8      }+common antiope-optparse-applicative   { build-depends: antiope-optparse-applicative   >= 7.0.1      && < 8      } common bytestring                     { build-depends: bytestring                     >= 0.10.8.2   && < 0.11   } common directory                      { build-depends: directory                      >= 1.3.3.0    && < 1.4    } common exceptions                     { build-depends: exceptions                     >= 0.10.1     && < 0.11   }@@ -35,8 +36,11 @@ common http-client                    { build-depends: http-client                    >= 0.5.14     && < 0.7    } common http-types                     { build-depends: http-types                     >= 0.12.3     && < 0.13   } common hw-hspec-hedgehog              { build-depends: hw-hspec-hedgehog              >= 0.1.0.4    && < 0.2    }+common hw-prim                        { build-depends: hw-prim                        >= 0.6.2.33   && < 0.7    } common lens                           { build-depends: lens                           >= 4.17       && < 5      } common mtl                            { build-depends: mtl                            >= 2.2.2      && < 2.3    }+common optparse-applicative           { build-depends: optparse-applicative           >= 0.14       && < 0.16   }+common unliftio-core                  { build-depends: unliftio-core                  >= 0.1.2.0    && < 0.2    } common resourcet                      { build-depends: resourcet                      >= 1.2.2      && < 1.3    } common text                           { build-depends: text                           >= 1.2.3.1    && < 1.3    } @@ -45,24 +49,26 @@   ghc-options:          -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates  library-  import:   base, config-          , aeson-          , amazonka-          , amazonka-core-          , amazonka-s3-          , antiope-core-          , antiope-s3-          , bytestring-          , directory-          , exceptions-          , filepath-          , generic-lens-          , http-client-          , http-types-          , lens-          , mtl-          , resourcet-          , text+  import:               base, config+                      , aeson+                      , amazonka+                      , amazonka-core+                      , amazonka-s3+                      , antiope-core+                      , antiope-s3+                      , bytestring+                      , directory+                      , exceptions+                      , filepath+                      , generic-lens+                      , http-client+                      , http-types+                      , hw-prim+                      , lens+                      , mtl+                      , resourcet+                      , text+                      , unliftio-core   other-modules:        Paths_hw_uri   autogen-modules:      Paths_hw_uri   hs-source-dirs:       src@@ -79,20 +85,41 @@                         HaskellWorks.Data.Uri.Text                         HaskellWorks.Data.Uri.UriError -test-suite hw-uri-test-  import:   base, config-          , antiope-core-          , antiope-s3-          , bytestring-          , aeson-          , filepath-          , hedgehog-          , hspec-          , http-types-          , hw-hspec-hedgehog-          , lens-          , text+executable hw-uri+  import:               base, config+                      , antiope-core+                      , antiope-optparse-applicative+                      , bytestring+                      , generic-lens+                      , lens+                      , mtl+                      , optparse-applicative+                      , resourcet+                      , text+  main-is:              Main.hs+  hs-source-dirs:       app+  ghc-options:          -threaded -rtsopts -with-rtsopts=-N+  build-depends:        hw-uri+  other-modules:        App.Aws.Logger+                        App.Commands+                        App.Commands.Cp+                        App.Commands.LsPrefix+                        App.Commands.Types+                        App.Show +test-suite hw-uri-test+  import:               base, config+                      , antiope-core+                      , antiope-s3+                      , bytestring+                      , aeson+                      , filepath+                      , hedgehog+                      , hspec+                      , http-types+                      , hw-hspec-hedgehog+                      , lens+                      , text   type:                 exitcode-stdio-1.0   main-is:              Spec.hs   build-depends:        hw-uri@@ -101,4 +128,5 @@   build-tool-depends:   hspec-discover:hspec-discover   other-modules:        HaskellWorks.Data.Uri.Gen                         HaskellWorks.Data.Uri.AwsSpec+                        HaskellWorks.Data.Uri.Internal.ListSpec                         HaskellWorks.Data.Uri.LocationSpec

@@ -1,16 +1,61 @@ {-# LANGUAGE OverloadedStrings #-}  module HaskellWorks.Data.Uri.IO.File-  ( listMaybeDirectory+  ( dirname+  , listMaybeDirectory+  , listFilesRecursiveWithPrefix+  , listDirectory+  , listFilesRecursive   ) where  import Control.Monad.Except+import Control.Monad.IO.Unlift+import Data.Semigroup          ((<>))+import System.FilePath -import qualified System.Directory as IO+import qualified Data.List                           as L+import qualified HaskellWorks.Control.Monad.Lazy     as IO+import qualified HaskellWorks.Data.Uri.Internal.List as L+import qualified System.Directory                    as IO +dirname :: FilePath -> FilePath+dirname filePath = case reverse (L.splitBy (== '/') ("$" <> filePath)) of+  []  -> filePath+  [_] -> filePath+  bs  -> drop 1 (L.intercalate "/" (reverse (drop 1 bs)))+ listMaybeDirectory :: MonadIO m => FilePath -> m [FilePath] listMaybeDirectory filepath = do   exists <- liftIO $ IO.doesDirectoryExist filepath   if exists-    then liftIO $ IO.listDirectory filepath+    then listDirectory filepath     else return []++listDirectory :: MonadIO m => FilePath -> m [FilePath]+listDirectory = liftIO . IO.listDirectory++listFilesRecursive :: (MonadIO m, MonadUnliftIO m) => FilePath -> m [FilePath]+listFilesRecursive filePath = do+  ps <- listDirectory filePath+  qs <- fmap concat $ IO.interleaveSequenceM $ fmap (recurse filePath) ps+  let rs = if filePath /= "." then fmap (filePath </>) qs else qs+  return rs++recurse :: (MonadIO m, MonadUnliftIO m) => FilePath -> FilePath -> m [FilePath]+recurse filePath p = do+  isDirectory <- liftIO $ IO.doesDirectoryExist (filePath </> p)+  if isDirectory+    then case filePath </> p of+      subPath -> if "./" `L.isPrefixOf` subPath+        then listFilesRecursive (drop 2 subPath)+        else listFilesRecursive subPath+    else return [p]++listFilesRecursiveWithPrefix :: (MonadIO m, MonadUnliftIO m) => FilePath -> m [FilePath]+listFilesRecursiveWithPrefix prefix = if '/' `elem` prefix+  then do+    fs <- listFilesRecursive (dirname prefix)+    return (filter (prefix `L.isPrefixOf`) fs)+  else do+    fs <- listFilesRecursive "."+    return (filter (prefix `L.isPrefixOf`) fs)

@@ -1,6 +1,8 @@+{-# LANGUAGE DataKinds           #-} {-# LANGUAGE LambdaCase          #-} {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}  module HaskellWorks.Data.Uri.IO.Lazy   ( readResource@@ -15,6 +17,7 @@   , linkOrCopyResource   , readHttpUri   , removePathRecursive+  , listResourcePrefix   ) where  import Antiope.Core@@ -23,6 +26,7 @@ import Control.Monad.Except import Control.Monad.Trans.Resource import Data.Either                    (isRight)+import Data.Generics.Product.Any import Data.Semigroup                 ((<>)) import Data.Text                      (Text) import HaskellWorks.Data.Uri.Location (Location (..))@@ -35,6 +39,7 @@ import qualified Data.ByteString.Lazy             as LBS import qualified Data.Text                        as T import qualified HaskellWorks.Data.Uri.IO.Console as CIO+import qualified HaskellWorks.Data.Uri.IO.File    as FIO import qualified HaskellWorks.Data.Uri.Location   as URI import qualified Network.AWS                      as AWS import qualified Network.AWS.S3.CopyObject        as AWS@@ -228,3 +233,9 @@         handler e = do           CIO.hPutStrLn IO.stderr $ "Warning: Caught " <> tshow e           return (Left (GenericUriError (tshow e)))++listResourcePrefix :: (MonadUnliftIO m, MonadResource m) => AWS.Env -> Location -> ExceptT UriError m [Location]+listResourcePrefix envAws location = case location of+  S3 s3Uri   -> fmap S3 <$> runAws envAws (AWS.lsPrefix (s3Uri ^. the @"bucket") (s3Uri ^. the @"objectKey" . the @1))+  Local path -> fmap Local <$> lift (FIO.listFilesRecursiveWithPrefix path)+  HttpUri _  -> throwError "HTTP PUT method not supported"

@@ -1,6 +1,7 @@ module HaskellWorks.Data.Uri.Internal.List   ( mapLast   , dropSave1+  , splitBy   ) where  mapLast :: (a -> a) -> [a] -> [a]@@ -12,3 +13,7 @@ dropSave1 [x]    = [x] dropSave1 (_:xs) = xs dropSave1 []     = []++splitBy :: (a -> Bool) -> [a] -> [[a]]+splitBy p as = if null as then [] else go as+  where go bs = let (cs, ds) = break p bs in cs:if null ds then [] else go (drop 1 ds)

@@ -0,0 +1,29 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE OverloadedStrings #-}++module HaskellWorks.Data.Uri.Internal.ListSpec+  ( spec+  ) where++import Control.Monad+import HaskellWorks.Hspec.Hedgehog+import Hedgehog+import Test.Hspec++import qualified Data.List                           as L+import qualified HaskellWorks.Data.Uri.Internal.List as L+import qualified Hedgehog.Gen                        as G+import qualified Hedgehog.Range                      as R++{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}+{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}+{-# ANN module ("HLint: ignore Redundant bracket"   :: String) #-}++spec :: Spec+spec = describe "HaskellWorks.Data.Uri.Internal.ListSpec" $ do+  it "splitBy" $ requireProperty $ do+    as <- forAll $ G.list (R.linear 1 3) (G.string (R.linear 0 3) G.alpha)+    when (as /= [""]) $ do+      annotateShow $ L.intercalate "/" as+      annotateShow $ L.splitBy (== '/') $ L.intercalate "/" as+      L.splitBy (== '/') (L.intercalate "/" as) === as