diff --git a/hw-uri.cabal b/hw-uri.cabal --- a/hw-uri.cabal +++ b/hw-uri.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: hw-uri -version: 0.1.1.0 +version: 0.1.1.1 synopsis: Supports IO on URIs description: Supports IO on URIs. homepage: https://github.com/haskell-works/hw-uri @@ -23,12 +23,13 @@ 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.1.1 && < 8 } -common antiope-s3 { build-depends: antiope-s3 >= 7.1.1 && < 8 } +common antiope-core { build-depends: antiope-core >= 7.3.3 && < 8 } +common antiope-s3 { build-depends: antiope-s3 >= 7.3.3 && < 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 } common filepath { build-depends: filepath >= 1.3 && < 1.5 } +common generic-lens { build-depends: generic-lens >= 1.1.0.0 && < 1.3 } common hedgehog { build-depends: hedgehog >= 0.5 && < 1.1 } common hspec { build-depends: hspec >= 2.4 && < 3 } common http-client { build-depends: http-client >= 0.5.14 && < 0.7 } @@ -55,6 +56,7 @@ , directory , exceptions , filepath + , generic-lens , http-client , http-types , lens @@ -64,17 +66,16 @@ other-modules: Paths_hw_uri autogen-modules: Paths_hw_uri hs-source-dirs: src - exposed-modules: - HaskellWorks.Data.Uri.AWS.Env - HaskellWorks.Data.Uri.IO.Console - HaskellWorks.Data.Uri.IO.Error - HaskellWorks.Data.Uri.IO.File - HaskellWorks.Data.Uri.IO.Lazy - HaskellWorks.Data.Uri.IO.Static - HaskellWorks.Data.Uri.Location - HaskellWorks.Data.Uri.Show - HaskellWorks.Data.Uri.Text - HaskellWorks.Data.Uri.UriError + exposed-modules: HaskellWorks.Data.Uri.AWS.Env + HaskellWorks.Data.Uri.IO.Console + HaskellWorks.Data.Uri.IO.Error + HaskellWorks.Data.Uri.IO.File + HaskellWorks.Data.Uri.IO.Lazy + HaskellWorks.Data.Uri.IO.Static + HaskellWorks.Data.Uri.Location + HaskellWorks.Data.Uri.Show + HaskellWorks.Data.Uri.Text + HaskellWorks.Data.Uri.UriError test-suite hw-uri-test import: base, config @@ -95,7 +96,7 @@ build-depends: hw-uri hs-source-dirs: test ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-tools: hspec-discover - other-modules: - HaskellWorks.Data.Uri.AwsSpec - HaskellWorks.Data.Uri.LocationSpec + build-tool-depends: hspec-discover:hspec-discover + other-modules: HaskellWorks.Data.Uri.Gen + HaskellWorks.Data.Uri.AwsSpec + HaskellWorks.Data.Uri.LocationSpec diff --git a/src/HaskellWorks/Data/Uri/Location.hs b/src/HaskellWorks/Data/Uri/Location.hs --- a/src/HaskellWorks/Data/Uri/Location.hs +++ b/src/HaskellWorks/Data/Uri/Location.hs @@ -1,13 +1,16 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module HaskellWorks.Data.Uri.Location ( IsPath(..) , Location(..) , toLocation + , dirname ) where import Antiope.Core (ToText (..), fromText) @@ -22,6 +25,7 @@ import qualified Data.Text as T import qualified System.FilePath as FP import qualified Data.Aeson.Types as J +import qualified Antiope.S3.Types as Z class IsPath a s | a -> s where () :: a -> s -> a @@ -106,6 +110,12 @@ | T.isInfixOf "://" txt' -> Nothing | otherwise -> Just (Local (T.unpack txt')) where txt' = T.strip txt + +dirname :: Location -> Location +dirname location = case location of + S3 s3Uri -> S3 (Z.dirname s3Uri) + Local fp -> Local (FP.takeDirectory fp) + HttpUri uri -> HttpUri (T.pack (FP.takeDirectory (T.unpack uri))) ------------------------------------------------------------------------------- stripStart :: Text -> Text -> Text diff --git a/test/HaskellWorks/Data/Uri/Gen.hs b/test/HaskellWorks/Data/Uri/Gen.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Uri/Gen.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +module HaskellWorks.Data.Uri.Gen + ( s3Uri + , location + , localPath + ) where + +import Antiope.Core (toText) +import Antiope.S3 (BucketName (..), ObjectKey (..), S3Uri (..)) +import Data.Aeson +import Data.Semigroup ((<>)) +import HaskellWorks.Data.Uri.Location +import HaskellWorks.Hspec.Hedgehog +import Hedgehog +import Test.Hspec + +import qualified Data.List as L +import qualified Data.Text as T +import qualified Hedgehog.Gen as G +import qualified Hedgehog.Range as R +import qualified System.FilePath as FP + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} +{-# ANN module ("HLint: ignore Redundant bracket" :: String) #-} + +s3Uri :: MonadGen m => m S3Uri +s3Uri = do + let partGen = G.text (R.linear 3 10) G.alphaNum + bkt <- partGen + parts <- G.list (R.linear 1 5) partGen + ext <- G.text (R.linear 2 4) G.alphaNum + pure $ S3Uri (BucketName bkt) (ObjectKey (T.intercalate "/" parts <> "." <> ext)) + +localPath :: MonadGen m => m FilePath +localPath = do + let partGen = G.string (R.linear 3 10) G.alphaNum + parts <- G.list (R.linear 1 5) partGen + ext <- G.string (R.linear 2 4) G.alphaNum + pure $ "/" <> L.intercalate "/" parts <> "." <> ext + +location :: MonadGen m => m Location +location = G.choice + [ S3 <$> s3Uri + , Local <$> localPath + , HttpUri . ("http://" <>) . T.pack <$> localPath + ] diff --git a/test/HaskellWorks/Data/Uri/LocationSpec.hs b/test/HaskellWorks/Data/Uri/LocationSpec.hs --- a/test/HaskellWorks/Data/Uri/LocationSpec.hs +++ b/test/HaskellWorks/Data/Uri/LocationSpec.hs @@ -6,7 +6,7 @@ ) where import Antiope.Core (toText) -import Antiope.S3 (BucketName (..), ObjectKey (..), S3Uri (..)) +import Antiope.S3 (S3Uri (..)) import Data.Aeson import Data.Semigroup ((<>)) import HaskellWorks.Data.Uri.Location @@ -14,67 +14,52 @@ import Hedgehog import Test.Hspec -import qualified Data.List as List -import qualified Data.Text as Text -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range -import qualified System.FilePath as FP +import qualified Data.Text as T +import qualified HaskellWorks.Data.Uri.Gen as G +import qualified Hedgehog.Gen as G +import qualified Hedgehog.Range as R +import qualified System.FilePath as FP {-# ANN module ("HLint: ignore Redundant do" :: String) #-} {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} {-# ANN module ("HLint: ignore Redundant bracket" :: String) #-} -s3Uri :: MonadGen m => m S3Uri -s3Uri = do - let partGen = Gen.text (Range.linear 3 10) Gen.alphaNum - bkt <- partGen - parts <- Gen.list (Range.linear 1 5) partGen - ext <- Gen.text (Range.linear 2 4) Gen.alphaNum - pure $ S3Uri (BucketName bkt) (ObjectKey (Text.intercalate "/" parts <> "." <> ext)) - -localPath :: MonadGen m => m FilePath -localPath = do - let partGen = Gen.string (Range.linear 3 10) Gen.alphaNum - parts <- Gen.list (Range.linear 1 5) partGen - ext <- Gen.string (Range.linear 2 4) Gen.alphaNum - pure $ "/" <> List.intercalate "/" parts <> "." <> ext - spec :: Spec spec = describe "HaskellWorks.Assist.LocationSpec" $ do it "S3 should roundtrip from and to text" $ requireProperty $ do - uri <- forAll s3Uri + uri <- forAll G.s3Uri tripping (S3 uri) toText toLocation it "LocalLocation should roundtrip from and to text" $ requireProperty $ do - path <- forAll localPath + path <- forAll G.localPath tripping (Local path) toText toLocation it "Should append s3 path" $ requireProperty $ do - loc <- S3 <$> forAll s3Uri - part <- forAll $ Gen.text (Range.linear 3 10) Gen.alphaNum - ext <- forAll $ Gen.text (Range.linear 2 4) Gen.alphaNum + loc <- S3 <$> forAll G.s3Uri + part <- forAll $ G.text (R.linear 3 10) G.alphaNum + ext <- forAll $ G.text (R.linear 2 4) G.alphaNum toText (loc part <.> ext) === (toText loc) <> "/" <> part <> "." <> ext toText (loc ("/" <> part) <.> ("." <> ext)) === (toText loc) <> "/" <> part <> "." <> ext it "Should replace s3 path extension" $ requireProperty $ do - loc <- S3 <$> forAll s3Uri - part <- forAll $ Gen.text (Range.linear 3 10) Gen.alphaNum - ext <- forAll $ Gen.text (Range.linear 2 4) Gen.alphaNum - ext' <- forAll $ Gen.text (Range.linear 2 4) Gen.alphaNum + loc <- S3 <$> forAll G.s3Uri + part <- forAll $ G.text (R.linear 3 10) G.alphaNum + ext <- forAll $ G.text (R.linear 2 4) G.alphaNum + ext' <- forAll $ G.text (R.linear 2 4) G.alphaNum toText (loc part <.> ext -<.> ext') === (toText loc) <> "/" <> part <> "." <> ext' toText (loc ("/" <> part) <.> ("." <> ext) -<.> ("." <> ext')) === (toText loc) <> "/" <> part <> "." <> ext' it "Should append local path" $ requireProperty $ do - loc <- Local <$> forAll localPath - part <- forAll $ Gen.string (Range.linear 3 10) Gen.alphaNum - ext <- forAll $ Gen.string (Range.linear 2 4) Gen.alphaNum - toText (loc Text.pack part <.> Text.pack ext) === Text.pack ((Text.unpack $ toText loc) FP. part FP.<.> ext) + loc <- Local <$> forAll G.localPath + part <- forAll $ G.string (R.linear 3 10) G.alphaNum + ext <- forAll $ G.string (R.linear 2 4) G.alphaNum + toText (loc T.pack part <.> T.pack ext) === T.pack ((T.unpack $ toText loc) FP. part FP.<.> ext) it "Should replace local path extension" $ requireProperty $ do - loc <- Local <$> forAll localPath - part <- forAll $ Gen.text (Range.linear 3 10) Gen.alphaNum - ext <- forAll $ Gen.text (Range.linear 2 4) Gen.alphaNum - ext' <- forAll $ Gen.text (Range.linear 2 4) Gen.alphaNum + loc <- Local <$> forAll G.localPath + part <- forAll $ G.text (R.linear 3 10) G.alphaNum + ext <- forAll $ G.text (R.linear 2 4) G.alphaNum + ext' <- forAll $ G.text (R.linear 2 4) G.alphaNum toText (loc part <.> ext -<.> ext') === (toText loc) <> "/" <> part <> "." <> ext' it "S3 uri should encode/decode to JSON" $ requireTest $ do @@ -92,3 +77,7 @@ it "HttpUri should encode/decode to JSON 2" $ requireTest $ do let location = HttpUri "https://tmp/path" fromJSON (toJSON location) === Success location + + it "dirname" $ requireTest $ do + location <- forAll G.location + dirname (location "x") === location