diff --git a/path-extra.cabal b/path-extra.cabal --- a/path-extra.cabal +++ b/path-extra.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 373b686527cf454dee43b179ea2c6733f768eb0bd0e1a6701bc6fddbe12fccc0 +-- hash: ef6199423093f720df1ad58097710e484ee8d805792c0f83655265f54fd65ded name: path-extra -version: 0.1.1 +version: 0.1.2 synopsis: Some extensions to Chris Done's path library, for use with urlpath and attoparsec-uri. description: Please see the README on Github at category: System, Filesystem, Web @@ -13,7 +13,7 @@ bug-reports: https://github.com/athanclark/path-extra/issues author: Athan Clark maintainer: athan.clark@localcooking.com -copyright: Copyright (c) 2018 Local Cooking Inc. +copyright: Copyright (c) 2018 Athan Clark license: BSD3 license-file: LICENSE build-type: Simple @@ -35,6 +35,28 @@ src ghc-options: -Wall build-depends: - base >=4.8 && <5 + attoparsec + , base >=4.8 && <5 , path + , text + default-language: Haskell2010 + +test-suite path-extra-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_path_extra + hs-source-dirs: + test + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck + , attoparsec + , base >=4.8 && <5 + , path + , path-extra + , quickcheck-instances + , tasty + , tasty-quickcheck + , text default-language: Haskell2010 diff --git a/src/Path/Extended.hs b/src/Path/Extended.hs --- a/src/Path/Extended.hs +++ b/src/Path/Extended.hs @@ -1,6 +1,9 @@ {-# LANGUAGE MultiParamTypeClasses , FunctionalDependencies + , NamedFieldPuns + , ScopedTypeVariables + , OverloadedStrings #-} module Path.Extended @@ -38,12 +41,22 @@ , (<#>) , delFragment , getFragment + , -- ** Parsers + locationAbsDirParser + , locationAbsFileParser ) where import Path as P hiding (()) import qualified Path as P (()) +import Prelude hiding (takeWhile) import Data.List (intercalate) +import Data.Attoparsec.Text (Parser, char, takeWhile, takeWhile1, sepBy, sepBy1) +import qualified Data.Text as T +import Data.Monoid ((<>)) +import Control.Applicative (Alternative (many), optional) +import Control.Exception (SomeException) +import Control.Monad (void) class PathAppend right base type' where @@ -76,6 +89,99 @@ , locQueryParams :: [QueryParam] , locFragment :: Maybe String } deriving (Eq, Ord) + + + + +locationAbsDirParser :: Parser (Location Abs Dir) +locationAbsDirParser = do + locPath <- absDir + locQueryParams <- do + xs <- optional $ do + let val = T.unpack <$> takeWhile (`notElem` ['=','&','#']) + void (char '?') + let kv = do + k <- val + mV <- optional $ do + void (char '=') + val + pure (k,mV) + kv `sepBy` void (char '&') + case xs of + Nothing -> pure [] + Just xs' -> pure xs' + locFragment <- optional $ do + void (char '#') + xs <- takeWhile (const True) + pure (T.unpack xs) + pure Location + { locParentJumps = 0 + , locPath + , locFileExt = Nothing + , locQueryParams + , locFragment + } + where + divider = void (char '/') + chunk = takeWhile1 (`notElem` ['?','&','/','#']) + absDir :: Parser (Path Abs Dir) + absDir = do + divider + xs <- many (chunk <* divider) + case parseAbsDir ( case xs of + [] -> "/" + _ -> T.unpack ("/" <> T.intercalate "/" xs <> "/") + ) of + Left (e :: SomeException) -> fail (show e) + Right x -> pure x + + +locationAbsFileParser :: Parser (Location Abs File) +locationAbsFileParser = do + (locPath, locFileExt) <- absFile + locQueryParams <- do + xs <- optional $ do + let val = T.unpack <$> takeWhile (`notElem` ['=','&','#']) + void (char '?') + let kv = do + k <- val + mV <- optional $ do + void (char '=') + val + pure (k,mV) + kv `sepBy` void (char '&') + case xs of + Nothing -> pure [] + Just xs' -> pure xs' + locFragment <- optional $ do + void (char '#') + xs <- takeWhile (const True) + pure (T.unpack xs) + pure Location + { locParentJumps = 0 + , locPath + , locFileExt + , locQueryParams + , locFragment + } + where + divider = void (char '/') + chunk = takeWhile1 (`notElem` ['?','&','/','#']) + absFile :: Parser (Path Abs File, Maybe String) + absFile = do + divider + xs <- chunk `sepBy1` divider + let (withoutFE,withFE) = T.breakOn "." (last xs) + xs' = init xs <> [withoutFE] + path <- case parseAbsFile (T.unpack ("/" <> T.intercalate "/" xs')) of + Left (e :: SomeException) -> fail (show e) + Right x -> pure x + pure + ( path + , if T.null withFE + then Nothing + else Just $ T.unpack $ T.drop 1 withFE + ) instance PathAppend Path Abs Dir where diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE + NamedFieldPuns + , OverloadedStrings + , ScopedTypeVariables + #-} + +module Main where + +import Path (parseAbsDir, parseAbsFile, Path, Abs, Dir, File) +import Path.Extended (Location (..), QueryParam, locationAbsDirParser, locationAbsFileParser) + +import qualified Data.Text as T +import Data.Monoid ((<>)) +import Data.Attoparsec.Text (parseOnly) +import Control.Exception (SomeException) +import Control.Monad (replicateM) + +import Test.Tasty (defaultMain, testGroup) +import qualified Test.Tasty.QuickCheck as QC +import Test.QuickCheck (Arbitrary (..), suchThat) +import Test.QuickCheck.Gen (Gen, choose, elements, listOf) +import Test.QuickCheck.Instances () + + + +newtype ArbitraryLocationAbsDir = ArbitraryLocationAbsDir + { getArbitraryLocationAbsDir :: Location Abs Dir + } deriving (Eq, Show) + +instance Arbitrary ArbitraryLocationAbsDir where + arbitrary = do + locPath <- arbitraryPath + locQueryParams <- arbitraryQueryParams + locFragment <- arbitraryFragment + pure $ ArbitraryLocationAbsDir Location + { locParentJumps = 0 + , locPath + , locFileExt = Nothing + , locQueryParams + , locFragment + } + where + arbitraryFragment :: Gen (Maybe String) + arbitraryFragment = do + build <- arbitrary + if not build + then pure Nothing + else + fmap Just $ listOf (elements (['A'..'Z'] <> ['a'..'z'])) `suchThat` (not . null) + + arbitraryQueryParams :: Gen [QueryParam] + arbitraryQueryParams = do + build <- arbitrary + if not build + then pure [] + else do + let arbitraryVal :: Gen String + arbitraryVal = + listOf (elements (['A'..'Z'] <> ['a'..'z'])) `suchThat` (not . null) + n <- choose (1,4) + let arbitraryKV :: Gen QueryParam + arbitraryKV = do + k <- arbitraryVal + buildVal <- arbitrary + mV <- + if buildVal + then Just <$> arbitraryVal + else pure Nothing + pure (k,mV) + replicateM n arbitraryKV + + arbitraryPath :: Gen (Path Abs Dir) + arbitraryPath = do + n <- choose (0,5) + xs <- replicateM n arbitraryChunk + pure $ case parseAbsDir ( case xs of + [] -> "/" + _ -> T.unpack ("/" <> T.intercalate "/" xs <> "/") + ) of + Left (e :: SomeException) -> + error $ "Can't parse abs dir! " <> show e + Right path -> path + + arbitraryChunk :: Gen T.Text + arbitraryChunk = fmap T.pack $ + listOf (elements (['A'..'Z'] <> ['a'..'z'])) `suchThat` (not . null) + + +newtype ArbitraryLocationAbsFile = ArbitraryLocationAbsFile + { getArbitraryLocationAbsFile :: Location Abs File + } deriving (Eq, Show) + +instance Arbitrary ArbitraryLocationAbsFile where + arbitrary = do + locPath <- arbitraryPath + locFileExt <- arbitraryFileExt + locQueryParams <- arbitraryQueryParams + locFragment <- arbitraryFragment + pure $ ArbitraryLocationAbsFile Location + { locParentJumps = 0 + , locPath + , locFileExt + , locQueryParams + , locFragment + } + where + arbitraryFragment :: Gen (Maybe String) + arbitraryFragment = do + build <- arbitrary + if not build + then pure Nothing + else + fmap Just $ listOf (elements (['A'..'Z'] <> ['a'..'z'])) `suchThat` (not . null) + + arbitraryQueryParams :: Gen [QueryParam] + arbitraryQueryParams = do + build <- arbitrary + if not build + then pure [] + else do + let arbitraryVal :: Gen String + arbitraryVal = + listOf (elements (['A'..'Z'] <> ['a'..'z'])) `suchThat` (not . null) + n <- choose (1,4) + let arbitraryKV :: Gen QueryParam + arbitraryKV = do + k <- arbitraryVal + buildVal <- arbitrary + mV <- + if buildVal + then Just <$> arbitraryVal + else pure Nothing + pure (k,mV) + replicateM n arbitraryKV + + arbitraryPath :: Gen (Path Abs File) + arbitraryPath = do + n <- choose (1,5) + xs <- replicateM n arbitraryChunk + pure $ case parseAbsFile ( case xs of + [] -> "/" + _ -> T.unpack ("/" <> T.intercalate "/" xs) + ) of + Left (e :: SomeException) -> + error $ "Can't parse abs file! " <> show e + Right path -> path + + arbitraryFileExt :: Gen (Maybe String) + arbitraryFileExt = do + build <- arbitrary + if not build + then pure Nothing + else + Just <$> listOf (elements (['A'..'Z'] <> ['a'..'z'])) `suchThat` (not . null) + + arbitraryChunk :: Gen T.Text + arbitraryChunk = fmap T.pack $ + listOf (elements (['A'..'Z'] <> ['a'..'z'])) `suchThat` (not . null) + + + +printParseIsoAbsDir :: ArbitraryLocationAbsDir -> Bool +printParseIsoAbsDir (ArbitraryLocationAbsDir loc) = + Right loc == parseOnly locationAbsDirParser (T.pack (show loc)) + +printParseIsoAbsFile :: ArbitraryLocationAbsFile -> Bool +printParseIsoAbsFile (ArbitraryLocationAbsFile loc) = + Right loc == parseOnly locationAbsFileParser (T.pack (show loc)) + + + +main :: IO () +main = defaultMain $ + testGroup "Path.Extended" + [ QC.testProperty "Print / Parse AbsDir Iso" printParseIsoAbsDir + , QC.testProperty "Print / Parse AbsFile Iso" printParseIsoAbsFile + ]