mismi-s3-core (empty) → 0.0.1
raw patch · 6 files changed
+491/−0 lines, 6 filesdep +attoparsecdep +basedep +hedgehog
Dependencies added: attoparsec, base, hedgehog, mismi-p, mismi-s3-core, text
Files
- LICENSE +30/−0
- mismi-s3-core.cabal +71/−0
- src/Mismi/S3/Core/Data.hs +194/−0
- test/Test/Mismi/S3/Core/Data.hs +120/−0
- test/Test/Mismi/S3/Core/Gen.hs +59/−0
- test/test.hs +17/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright 2017, Nick Hibberd <nhibberd@gmail.com>, All Rights Reserved.++Copyright 2017, Ambiata, All Rights Reserved.++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.
+ mismi-s3-core.cabal view
@@ -0,0 +1,71 @@+version: 0.0.1++name:+ mismi-s3-core+author:+ Nick Hibberd+maintainer:+ Nick Hibberd <nhibberd@gmail.com>+homepage:+ https://github.com/nhibberd/mismi+bug-reports:+ https://github.com/nhibberd/mismi/issues+synopsis:+ AWS Library+description:+ mismi-s3-core provides a set of data types around S3 concepts and+ useful functions over them.+category:+ AWS+license:+ BSD3+license-file:+ LICENSE+cabal-version:+ >= 1.8+build-type:+ Simple+tested-with:+ GHC == 8.2.2+ , GHC == 8.4.3++library+ build-depends:+ base >= 3 && < 5+ , mismi-p+ , attoparsec >= 0.12 && < 0.14+ , text >= 1.1 && < 1.3++ ghc-options:+ -Wall++ hs-source-dirs:+ src+++ exposed-modules:+ Mismi.S3.Core.Data++test-suite test+ type:+ exitcode-stdio-1.0++ main-is:+ test.hs++ ghc-options:+ -Wall -threaded -O2++ hs-source-dirs:+ test++ other-modules:+ Test.Mismi.S3.Core.Data+ Test.Mismi.S3.Core.Gen++ build-depends:+ base >= 3 && < 5+ , mismi-s3-core+ , mismi-p+ , hedgehog+ , text >= 1.1 && < 1.3
+ src/Mismi/S3/Core/Data.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module Mismi.S3.Core.Data (+ WriteMode (..)+ , SyncMode (..)+ , Bucket (..)+ , Address (..)+ , Key (..)+ , ReadGrant (..)+ , WriteResult (..)+ , Bytes (..)+ , Sized (..)+ , (//)+ , combineKey+ , dirname+ , foldWriteMode+ , foldSyncMode+ , basename+ , addressFromText+ , addressToText+ , removeCommonPrefix+ , withKey+ , s3Parser+ ) where++import Data.Attoparsec.Text (Parser)+import Data.Attoparsec.Text (anyChar, char, manyTill, string, takeWhile)+import Data.Attoparsec.Text (endOfInput, parseOnly)+import Data.Data (Data, Typeable)+import Data.List (drop, init, reverse, zipWith)+import Data.String (String)+import qualified Data.Text as T++import P+import Prelude (Integral)++data WriteResult =+ WriteOk+ | WriteDestinationExists !Address+ deriving (Eq, Show)++-- |+-- Describes the semantics for destructive operation that may result in overwritten files.+--+data WriteMode =+ Fail -- ^ Fail rather than overwrite any data.+ | Overwrite -- ^ Overwrite existing data silently, i.e. we really want to do this.+ deriving (Eq, Show)++foldWriteMode :: a -> a -> WriteMode -> a+foldWriteMode f o m =+ case m of+ Fail ->+ f+ Overwrite ->+ o++data SyncMode =+ FailSync+ | OverwriteSync+ | SkipSync+ deriving (Eq, Show)++foldSyncMode :: a -> a -> a -> SyncMode -> a+foldSyncMode f o s m =+ case m of+ FailSync ->+ f+ OverwriteSync ->+ o+ SkipSync ->+ s++newtype Bucket =+ Bucket {+ unBucket :: Text+ } deriving (Eq, Show, Ord, Data, Typeable)++newtype Key =+ Key {+ unKey :: Text+ } deriving (Eq, Show, Ord, Data, Typeable)++data Address =+ Address {+ bucket :: !Bucket+ , key :: !Key+ } deriving (Eq, Show, Ord, Data, Typeable)++newtype ReadGrant =+ ReadGrant {+ readGrant :: Text+ } deriving (Eq, Show)++newtype Bytes =+ Bytes {+ unBytes :: Int64+ } deriving (Eq, Show, Ord, Enum, Num, Real, Integral)++data Sized a =+ Sized {+ sizedBytes :: !Bytes+ , sizedValue :: !a+ } deriving (Eq, Show, Ord, Functor, Foldable, Traversable)++(//) :: Key -> Key -> Key+(//) =+ combineKey++combineKey :: Key -> Key -> Key+combineKey (Key p1) (Key p2) =+ if "/" `T.isSuffixOf` p1 || p1 == "" || "/" `T.isPrefixOf` p2 then+ Key $ p1 <> p2+ else+ Key $ p1 <> "/" <> p2++-- | @withKey f address@ : Replace the 'Key' part of an 'Address' with a new+-- 'Key' resulting from the application of function @f@ to the old 'Key'.+withKey :: (Key -> Key) -> Address -> Address+withKey f (Address b k) =+ Address b $ f k++-- | Get the prefix for a given key (eg. dirname "\/foo\/bar" == "foo").+dirname :: Key -> Key+dirname =+ Key . T.intercalate "/" . init . T.split (=='/') . unKey++-- | Get the basename for a given key (eg. basename "\/foo\/bar" == "bar").+-- Return 'Nothing' for the empty 'Key' _and_ when the name ends with a "/".+basename :: Key -> Maybe Text+basename =+ mfilter (not . T.null) . listToMaybe . reverse . T.split (== '/') . unKey++-- prefix key+removeCommonPrefix :: Address -> Address -> Maybe Key+removeCommonPrefix prefix addr =+ let+ dropMaybe :: String -> String -> Maybe Text+ dropMaybe x y =+ bool+ Nothing+ (Just . T.pack $ drop (length y) x)+ (check x y)++ check :: String -> String -> Bool+ check x y =+ y == zipWith const x y+ in+ if bucket addr == bucket prefix then+ if unKey (key prefix) == "" then+ Just $ key addr+ else+ let+ bk = unKey (key prefix)+ b = bool (bk <> "/") bk ("/" `T.isSuffixOf` bk)+ pk = T.unpack b+ kk = T.unpack (unKey $ key addr)+ in+ Key <$> dropMaybe kk pk+ else+ Nothing++-- | Render an 'Address' to 'Text', including the "s3://" prefix.+addressToText :: Address -> Text+addressToText a =+ "s3://" <> unBucket (bucket a) <> "/" <> unKey (key a)++-- | Parse an 'Address' from 'Text'. If the parse fails, 'Nothing' is returned.+addressFromText :: Text -> Maybe Address+addressFromText =+ hush . parseOnly s3Parser++s3Parser :: Parser Address+s3Parser =+ s3Parser' <|> s3Parser''++s3Parser' :: Parser Address+s3Parser' = do+ _ <- string "s3://"+ b <- manyTill anyChar (char '/')+ k <- many anyChar+ pure $ Address (Bucket . T.pack $ b) (Key . T.pack $ k)++s3Parser'' :: Parser Address+s3Parser'' = do+ _ <- string "s3://"+ b <- takeWhile (/= '/')+ endOfInput+ pure $ Address (Bucket b) (Key "")
+ test/Test/Mismi/S3/Core/Data.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module Test.Mismi.S3.Core.Data (tests) where++import qualified Data.Text as T+import qualified Data.List as L++import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Mismi.S3.Core.Data++import P++import Test.Mismi.S3.Core.Gen+++prop_append :: Property+prop_append =+ property $ do+ p1 <- forAll genKey+ p2 <- forAll genKey+ T.count "//" (unKey (p1 // p2)) === 0+++prop_appendEdge :: Property+prop_appendEdge =+ property $ do+ m <- forAll $ Gen.text (Range.singleton 5) Gen.alphaNum+ s <- forAll $ Gen.text (Range.singleton 5) Gen.alphaNum+ Key (m <> "/") // Key s === Key (m <> "/" <> s)+ Key m // Key ("/" <> s) === Key (m <> "/" <> s)+ Key m // Key s === Key (m <> "/" <> s)+++prop_parse :: Property+prop_parse =+ property $ do+ a <- forAll genAddress+ addressFromText (addressToText a) === Just a++prop_parse_bucket :: Property+prop_parse_bucket =+ property $ do+ b <- forAll genBucket+ addressFromText ("s3://" <> unBucket b) === Just (Address b (Key ""))++prop_sorted :: Property+prop_sorted =+ withTests 10 . property $ do+ addresses <- forAll $ Gen.list (Range.linear 0 100) genAddress+ fmap addressToText (L.sort addresses) === L.sort (fmap addressToText addresses)++prop_withKey :: Property+prop_withKey =+ property $ do+ a <- forAll genAddress+ withKey id a === a++prop_withKey_dirname :: Property+prop_withKey_dirname =+ property $ do+ a <- forAll genAddress+ key (withKey dirname a) === (dirname . key) a++prop_withKey_key :: Property+prop_withKey_key =+ property $ do+ a <- forAll genAddress+ k <- forAll genKey+ key (withKey (// k) a) === (key a) // k++prop_basename :: Property+prop_basename =+ property $ do+ k <- forAll genKey+ bn <- forAll $ Gen.text (Range.linear 1 20) Gen.alphaNum+ basename (k // (Key bn)) === Just bn++prop_basename_prefix :: Property+prop_basename_prefix =+ property $ do+ k <- forAll genKey+ bn <- forAll $ Gen.text (Range.linear 1 20) Gen.alphaNum+ basename (k // (Key $ bn <> "/")) === Nothing++prop_basename_root :: Property+prop_basename_root =+ property $+ basename (Key "") === Nothing++prop_dirname :: Property+prop_dirname =+ property $ do+ a <- forAll genAddress+ t <- forAll $ Gen.text (Range.linear 1 20) Gen.alphaNum+ let+ k = Key t+ dirname (key a // k) === Key (T.dropWhileEnd ('/' ==) . unKey . key $ a)++prop_commonPrefix :: Property+prop_commonPrefix =+ property $ do+ a <- forAll genAddress+ k <- forAll genKey+ removeCommonPrefix a (withKey (// k) a) === Just k++prop_commonPrefix_fail :: Property+prop_commonPrefix_fail =+ property $ do+ a <- forAll genAddress+ k <- forAll genKey+ removeCommonPrefix (withKey (// k) a) a === Nothing+++tests :: IO Bool+tests =+ checkSequential $$(discover)
+ test/Test/Mismi/S3/Core/Gen.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module Test.Mismi.S3.Core.Gen (+ genWriteMode+ , genBucket+ , genKey+ , genAddress+ , fileNameSizePairs+ ) where++import qualified Data.List as L+import qualified Data.Text as T++import Mismi.S3.Core.Data++import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import P+++genWriteMode :: Gen WriteMode+genWriteMode =+ Gen.element [Fail, Overwrite]++genBucket :: Gen Bucket+genBucket =+ Bucket <$>+ Gen.text (Range.linear 10 20) Gen.alphaNum++-- The max length of S3 Paths is 1024 - and we append some of them in the tests+-- Unfortunately unicode characters aren't supported in the Haskell AWS library+genKey :: Gen Key+genKey =+ let+ genPath = Gen.element ["happy", "sad", ".", ":", "-"]+ listOf1 gen = Gen.list (Range.linear 1 50) gen+ path = do+ sep <- Gen.element ["-", "=", "#", ""]+ T.take 256 . T.intercalate "/" <$> listOf1 (T.intercalate sep <$> listOf1 genPath)+ in+ (Key . T.append "tests/") <$> path+++genAddress :: Gen Address+genAddress =+ Gen.frequency [+ (9, Address <$> genBucket <*> genKey)+ , (1, Address <$> genBucket <*> (pure $ Key ""))+ ]++fileNameSizePairs :: Int -> Gen [(FilePath, Int64)]+fileNameSizePairs len = do+ names <- Gen.list (Range.singleton len) $ Gen.string (Range.linear 10 20) Gen.alphaNum+ lengths <- Gen.list (Range.singleton len) $ Gen.int64 (Range.linear 1 1000000000)+ let+ zipper n i l = (n <> show i, l)+ pure $ L.zipWith3 zipper names [(0::Int) ..] lengths
+ test/test.hs view
@@ -0,0 +1,17 @@+import Control.Monad (unless)++import System.Exit (exitFailure)+import System.IO (BufferMode(..), hSetBuffering, stdout, stderr)++import qualified Test.Mismi.S3.Core.Data++main :: IO ()+main = do+ hSetBuffering stdout LineBuffering+ hSetBuffering stderr LineBuffering++ results <- sequence [+ Test.Mismi.S3.Core.Data.tests+ ]++ unless (and results) exitFailure