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.2 +version: 0.1.1.3 synopsis: Supports IO on URIs description: Supports IO on URIs. homepage: https://github.com/haskell-works/hw-uri @@ -67,6 +67,8 @@ autogen-modules: Paths_hw_uri hs-source-dirs: src exposed-modules: HaskellWorks.Data.Uri.AWS.Env + HaskellWorks.Data.Uri.Internal.List + HaskellWorks.Data.Uri.Internal.Text HaskellWorks.Data.Uri.IO.Console HaskellWorks.Data.Uri.IO.Error HaskellWorks.Data.Uri.IO.File diff --git a/src/HaskellWorks/Data/Uri/Internal/List.hs b/src/HaskellWorks/Data/Uri/Internal/List.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Uri/Internal/List.hs @@ -0,0 +1,14 @@ +module HaskellWorks.Data.Uri.Internal.List + ( mapLast + , dropSave1 + ) where + +mapLast :: (a -> a) -> [a] -> [a] +mapLast f [a] = [f a] +mapLast _ [] = [] +mapLast f (a:as) = a:mapLast f as + +dropSave1 :: [a] -> [a] +dropSave1 (_:xs) = xs +dropSave1 [x] = [x] +dropSave1 [] = [] diff --git a/src/HaskellWorks/Data/Uri/Internal/Text.hs b/src/HaskellWorks/Data/Uri/Internal/Text.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Uri/Internal/Text.hs @@ -0,0 +1,15 @@ +module HaskellWorks.Data.Uri.Internal.Text + ( maybeStripPrefix + , maybeStripSuffix + ) where + +import Data.Maybe +import Data.Text (Text) + +import qualified Data.Text as T + +maybeStripPrefix :: Text -> Text -> Text +maybeStripPrefix what txt = fromMaybe txt (T.stripPrefix what txt) + +maybeStripSuffix :: Text -> Text -> Text +maybeStripSuffix what txt = fromMaybe txt (T.stripSuffix what txt) 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 @@ -13,23 +13,31 @@ , toLocation , basename , dirname + , modPath + , getPath + , modBasename + , modBasenameParts + , modBasenamePartsReversed + , modExts ) where import Antiope.Core (ToText (..), fromText) import Antiope.S3 (ObjectKey (..), S3Uri (..)) import Control.Applicative -import Control.Lens ((^.)) +import Control.Lens ((%~), (&), (^.)) import Data.Aeson import Data.Generics.Product.Any -import Data.Maybe (fromMaybe) import Data.Semigroup ((<>)) import Data.Text (Text) import GHC.Generics (Generic) -import qualified Antiope.S3.Types as Z -import qualified Data.Aeson.Types as J -import qualified Data.Text as T -import qualified System.FilePath as FP +import qualified Antiope.S3.Types as Z +import qualified Data.Aeson.Types as J +import qualified Data.List as L +import qualified Data.Text as T +import qualified HaskellWorks.Data.Uri.Internal.List as L +import qualified HaskellWorks.Data.Uri.Internal.Text as T +import qualified System.FilePath as FP class IsPath a s | a -> s where () :: a -> s -> a @@ -98,13 +106,13 @@ instance IsPath S3Uri Text where S3Uri b (ObjectKey k) p = - S3Uri b (ObjectKey (stripEnd "/" k <> "/" <> stripStart "/" p)) + S3Uri b (ObjectKey (T.maybeStripSuffix "/" k <> "/" <> T.maybeStripPrefix "/" p)) S3Uri b (ObjectKey k) <.> e = - S3Uri b (ObjectKey (stripEnd "." k <> "." <> stripStart "." e)) + S3Uri b (ObjectKey (T.maybeStripSuffix "." k <> "." <> T.maybeStripPrefix "." e)) S3Uri b (ObjectKey k) -<.> e = - S3Uri b (ObjectKey (stripEnd "." (T.pack . (FP.-<.> (T.unpack $ stripStart "." e)) . T.unpack $ k))) + S3Uri b (ObjectKey (T.maybeStripSuffix "." (T.pack . (FP.-<.> (T.unpack $ T.maybeStripPrefix "." e)) . T.unpack $ k))) toLocation :: Text -> Maybe Location toLocation txt = if @@ -127,9 +135,31 @@ Local fp -> T.pack $ FP.takeFileName fp HttpUri uri -> T.pack . FP.takeFileName $ T.unpack uri -------------------------------------------------------------------------------- -stripStart :: Text -> Text -> Text -stripStart what txt = fromMaybe txt (T.stripPrefix what txt) +modPath :: (Text -> Text) -> Location -> Location +modPath f location = case location of + S3 s3Uri -> S3 (s3Uri & the @"objectKey" . the @1 %~ f) + Local fp -> Local (T.unpack (f (T.pack fp))) + HttpUri uri -> HttpUri (f uri) -stripEnd :: Text -> Text -> Text -stripEnd what txt = fromMaybe txt (T.stripSuffix what txt) +getPath :: Location -> Text +getPath location = case location of + S3 s3Uri -> s3Uri ^. the @"objectKey" . the @1 + Local fp -> T.pack fp + HttpUri uri -> uri + +modBasename :: (Text -> Text) -> Location -> Location +modBasename f = modPath g + where g path = T.intercalate "/" (L.mapLast f (T.splitOn "/" path)) + +modBasenameParts :: ([Text] -> [Text]) -> Location -> Location +modBasenameParts f = modBasename (T.intercalate "." . f . T.splitOn ".") + +modBasenamePartsReversed :: ([Text] -> [Text]) -> Location -> Location +modBasenamePartsReversed f = modBasenameParts (reverse . f . reverse) + +modExts :: [Text] -> [Text] -> Location -> Location +modExts fromExts toExts = modBasenameParts f + where f :: [Text] -> [Text] + f as = if L.isSuffixOf fromExts as + then (reverse (drop (length fromExts) (reverse as))) <> toExts + else as 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 @@ -1,5 +1,6 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module HaskellWorks.Data.Uri.LocationSpec ( spec @@ -7,8 +8,11 @@ import Antiope.Core (toText) import Antiope.S3 (S3Uri (..)) +import Control.Lens ((&)) import Data.Aeson +import Data.Maybe import Data.Semigroup ((<>)) +import Data.Text (Text) import HaskellWorks.Data.Uri.Location import HaskellWorks.Hspec.Hedgehog import Hedgehog @@ -81,3 +85,40 @@ it "dirname" $ requireTest $ do location <- forAll G.location dirname (location "x") === location + + it "modPath" $ requireTest $ do + let input :: Location = fromJust (toLocation ("s3://bucket/object/key.ext")) + let actual :: Location = input & modPath T.toUpper + let expected :: Location = fromJust (toLocation ("s3://bucket/OBJECT/KEY.EXT")) + actual === expected + + it "getPath" $ requireTest $ do + let input :: Location = fromJust (toLocation ("s3://bucket/object/key.ext")) + let actual :: Text = input & getPath + let expected :: Text = "object/key.ext" + actual === expected + + it "modBasename" $ requireTest $ do + let input :: Location = fromJust (toLocation ("s3://bucket/object/key.ext")) + let actual :: Location = input & modBasename T.toUpper + let expected :: Location = fromJust (toLocation ("s3://bucket/object/KEY.EXT")) + actual === expected + + it "modBasenameParts" $ requireTest $ do + let input :: Location = fromJust (toLocation ("s3://bucket/object/ab.cd.ef")) + let actual :: Location = input & modBasenameParts (reverse . drop 1) + let expected :: Location = fromJust (toLocation ("s3://bucket/object/ef.cd")) + actual === expected + + it "modBasenamePartsReversed" $ requireTest $ do + let input :: Location = fromJust (toLocation ("s3://bucket/object/ab.cd.ef")) + let actual :: Location = input & modBasenamePartsReversed (drop 1) + let expected :: Location = fromJust (toLocation ("s3://bucket/object/ab.cd")) + actual === expected + + it "modExts" $ requireTest $ do + let input :: Location = fromJust (toLocation ("s3://bucket/object/ab.cd.ef")) + let actual :: Location = input & modExts ["cd", "ef"] ["gh", "ij"] + let expected :: Location = fromJust (toLocation ("s3://bucket/object/ab.gh.ij")) + actual === expected +