diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,21 @@ +## Slug 0.1.6 + +* Allowed Aeson 1.1. + +* Switched to Hspec for test suite. + +* Made public `Arbitrary` instance for `Slug`. + +* Derived `Eq` for `SlugException`. + +* Drop support for GHC 7.6. + +* Started to use the derived `Show` instance for `SlugException`. + Human-friendly version goes to `Exception`'s method `displayException` + instead. + +* Added instances of `ToHttpApiData` and `FromHttpApiData` for `Slug`. + ## Slug 0.1.5 * Allow Aeson 1.0. diff --git a/LICENSE.md b/LICENSE.md --- a/LICENSE.md +++ b/LICENSE.md @@ -1,4 +1,4 @@ -Copyright © 2015–2016 Mark Karpov +Copyright © 2015–2017 Mark Karpov All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -54,6 +54,6 @@ ## License -Copyright © 2015–2016 Mark Karpov +Copyright © 2015–2017 Mark Karpov Distributed under BSD 3 clause license. diff --git a/Web/Slug.hs b/Web/Slug.hs --- a/Web/Slug.hs +++ b/Web/Slug.hs @@ -1,6 +1,6 @@ -- | -- Module : Web.Slug --- Copyright : © 2015–2016 Mark Karpov +-- Copyright : © 2015–2017 Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov @@ -9,6 +9,7 @@ -- -- Type-safe slug implementation for Yesod ecosystem. +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TupleSections #-} @@ -21,21 +22,28 @@ , SlugException (..) ) where -import Control.Exception (Exception) +import Control.Exception (Exception (..)) import Control.Monad ((>=>), liftM) import Control.Monad.Catch (MonadThrow (..)) import Data.Aeson.Types (ToJSON (..), FromJSON (..)) import Data.Char (isAlphaNum) import Data.Data (Data) +import Data.Maybe (isJust, fromJust) import Data.Text (Text) import Data.Typeable (Typeable) import Database.Persist.Class (PersistField (..)) import Database.Persist.Sql (PersistFieldSql (..)) import Database.Persist.Types (SqlType (..)) +import Test.QuickCheck +import Web.HttpApiData import Web.PathPieces import qualified Data.Aeson as A import qualified Data.Text as T +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif + -- | This exception is thrown by 'mkSlug' when its input cannot be converted -- into proper 'Slug'. @@ -43,14 +51,14 @@ = InvalidInput Text -- ^ Slug cannot be generated for given text | InvalidSlug Text -- ^ Input is not a valid slug, see 'parseSlug' | InvalidLength Int -- ^ Requested slug length is not a positive number - deriving (Typeable) - -instance Show SlugException where - show (InvalidInput text) = "Cannot build slug for " ++ show text - show (InvalidSlug text) = "The text is not a valid slug " ++ show text - show (InvalidLength n) = "Invalid slug length: " ++ show n + deriving (Eq, Show, Typeable) -instance Exception SlugException +instance Exception SlugException where +#if MIN_VERSION_base(4,8,0) + displayException (InvalidInput text) = "Cannot build slug for " ++ show text + displayException (InvalidSlug text) = "The text is not a valid slug " ++ show text + displayException (InvalidLength n) = "Invalid slug length: " ++ show n +#endif -- | Slug. Textual value inside is always guaranteed to have the following -- qualities: @@ -145,7 +153,13 @@ instance PersistField Slug where toPersistValue = toPersistValue . unSlug fromPersistValue = - fromPersistValue >=> either (Left . T.pack . show) Right . parseSlug + fromPersistValue >=> either (Left . T.pack . f) Right . parseSlug + where +#if MIN_VERSION_base(4,8,0) + f = displayException +#else + f = show +#endif instance PersistFieldSql Slug where sqlType = const SqlString @@ -153,3 +167,18 @@ instance PathPiece Slug where fromPathPiece = parseSlug toPathPiece = unSlug + +instance ToHttpApiData Slug where + toUrlPiece = unSlug + +instance FromHttpApiData Slug where + parseUrlPiece = either (Left . T.pack . f) Right . parseSlug + where +#if MIN_VERSION_base(4,8,0) + f = displayException +#else + f = show +#endif + +instance Arbitrary Slug where + arbitrary = fromJust <$> (mkSlug . T.pack <$> arbitrary) `suchThat` isJust diff --git a/slug.cabal b/slug.cabal --- a/slug.cabal +++ b/slug.cabal @@ -1,7 +1,7 @@ -- -- Cabal configuration for ‘slug’. -- --- Copyright © 2015–2016 Mark Karpov +-- Copyright © 2015–2017 Mark Karpov -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are @@ -31,7 +31,7 @@ -- POSSIBILITY OF SUCH DAMAGE. name: slug -version: 0.1.5 +version: 0.1.6 cabal-version: >= 1.10 license: BSD3 license-file: LICENSE.md @@ -52,9 +52,11 @@ default: False library - build-depends: aeson >= 0.8 && < 1.1 - , base >= 4.6 && < 5.0 + build-depends: QuickCheck >= 2.4 && < 3.0 + , aeson >= 0.8 && < 1.2 + , base >= 4.7 && < 5.0 , exceptions >= 0.6 && < 0.9 + , http-api-data >= 0.2 && < 0.4 , path-pieces >= 0.1.5 && < 0.3 , persistent >= 2.0 && < 3.0 , text >= 1.0 && < 1.3 @@ -75,14 +77,14 @@ else ghc-options: -O2 -Wall default-extensions: OverloadedStrings - build-depends: QuickCheck >= 2.4 && < 3.0 - , base >= 4.6 && < 5.0 - , exceptions >= 0.6 && < 0.9 - , path-pieces >= 0.1.5 && < 0.3 - , slug >= 0.1.5 - , test-framework >= 0.6 && < 1.0 - , test-framework-quickcheck2 >= 0.3 && < 0.4 - , text >= 1.0 && < 1.3 + build-depends: QuickCheck >= 2.4 && < 3.0 + , base >= 4.7 && < 5.0 + , exceptions >= 0.6 && < 0.9 + , hspec >= 2.0 && < 3.0 + , http-api-data >= 0.2 && < 0.4 + , path-pieces >= 0.1.5 && < 0.3 + , slug >= 0.1.6 + , text >= 1.0 && < 1.3 default-language: Haskell2010 source-repository head diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,7 +1,7 @@ -- -- Slug tests. -- --- Copyright © 2015–2016 Mark Karpov +-- Copyright © 2015–2017 Mark Karpov -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are @@ -36,14 +36,13 @@ module Main (main) where import Control.Monad ((>=>)) -import Control.Monad.Catch (MonadThrow (..)) import Data.Char (isAlphaNum, isUpper) import Data.Function (on) -import Data.Maybe (fromJust, isJust, isNothing) +import Data.Maybe (isJust, isNothing) import Data.Text (Text) -import Test.Framework -import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.Hspec import Test.QuickCheck +import Web.HttpApiData import Web.PathPieces import Web.Slug import qualified Data.Text as T @@ -53,60 +52,76 @@ #endif main :: IO () -main = defaultMain [tests] - -tests :: Test -tests = testGroup "Slug properties" - [ -- Properties of valid slugs - testProperty "Slug cannot be empty" prop_nonEmpty - , testProperty "Only dashes and alpha-numeric" prop_validContent - , testProperty "Slug cannot begin with a dash" prop_noBegDash - , testProperty "Slug cannot end with a dash" prop_noEndDash - , testProperty "Non-empty word between dashes" prop_noEmptyWords - , testProperty "No upper-cased chars in slugs" prop_noUpperCase - -- Properties of helper-functions - , testProperty "Slug of slug is the slug" prop_changeStops - , testProperty "Parsing of slugs (success)" prop_parsing0 - , testProperty "Parsing of slugs (failure)" prop_parsing1 - , testProperty "Slug truncation" prop_truncation - , testProperty "Reading of slugs (success)" prop_read0 - , testProperty "Reading of slugs (failure)" prop_read1 - -- Additional properties - , testProperty "Rendering of slugs" prop_showSlug - , testProperty "Alpha-numerics are necessary and sufficient" prop_needAlphaNum - , testProperty "Path pieces accept correct slugs" prop_pathPiece - ] - -instance Arbitrary Text where - arbitrary = T.pack <$> arbitrary - -instance Arbitrary Slug where - arbitrary = fromJust <$> ((mkSlug <$> arbitrary) `suchThat` isJust) - ----------------------------------------------------------------------------- --- Properties of valid slugs - -prop_nonEmpty :: Slug -> Property -prop_nonEmpty = expectFailure . T.null . unSlug - -prop_validContent :: Slug -> Property -prop_validContent = property . T.all f . unSlug - where f x = isAlphaNum x || x == '-' - -prop_noBegDash :: Slug -> Property -prop_noBegDash s = expectFailure $ T.head (unSlug s) === '-' - -prop_noEndDash :: Slug -> Property -prop_noEndDash s = expectFailure $ T.last (unSlug s) === '-' - -prop_noEmptyWords :: Slug -> Property -prop_noEmptyWords = expectFailure . any T.null . T.splitOn "-" . unSlug +main = hspec spec -prop_noUpperCase :: Slug -> Property -prop_noUpperCase = expectFailure . T.any isUpper . unSlug +spec :: Spec +spec = do + describe "slug properties" $ do + it "cannot be empty" $ + property $ \slug -> + unSlug slug `shouldNotSatisfy` T.null + it "contains only dashes and alpha-numeric characters" $ + property $ \slug -> + let f x = isAlphaNum x || x == '-' + in unSlug slug `shouldSatisfy` T.all f + it "does not begin with a dash" $ + property $ \slug -> + T.head (unSlug slug) `shouldNotBe` '-' + it "does not end with a dash" $ + property $ \slug -> + T.last (unSlug slug) `shouldNotBe` '-' + it "does not contain empty words between dashes" $ + property $ \slug -> + T.splitOn "-" (unSlug slug) `shouldNotSatisfy` any T.null + it "no upper-cased chars found in slugs" $ + property $ \slug -> + unSlug slug `shouldNotSatisfy` T.any isUpper + it "showed Slug looks the same as its inner Text" $ + property $ \slug -> + show slug === show (unSlug slug) + it "showed Slug can be read back again" $ + property $ \slug -> + read (show slug) === (slug :: Slug) + it "incorrect Slug won't be read successfully" $ + property $ \x -> isNothing (parseSlug x) ==> + (reads (show x) :: [(Slug, String)]) === [] + it "valid Slug text is a valid path piece" $ + property $ \slug -> + fromPathPiece (unSlug slug) === Just slug + it "valid Slug text is a valid HTTP API data" $ + property $ \slug -> + parseUrlPiece (toUrlPiece slug) === Right (slug :: Slug) + describe "mkSlug" $ do + it "Slug transformation in idempotent" $ + property $ \x -> + let f = mkSlug + g = mkSlug >=> mkSlug . unSlug + in f x ==== g x + it "text containing at least one alpha-num char is Sluggable" $ do + let hasAlphaNum = isJust . T.find isAlphaNum + property $ \x -> hasAlphaNum x ==> + isJust (mkSlug x) `shouldBe` True + describe "parseSlug" $ do + it "succeeds on valid input" $ + property $ \slug -> + parseSlug (unSlug slug) `shouldReturn` slug + it "fails on invalid input" $ + property $ \x -> + (unSlug <$> mkSlug x) `notElem` [Nothing, Just x] ==> + parseSlug x `shouldThrow` (== InvalidSlug x) + describe "truncateSlug" $ do + context "when required length is less than 0" $ + it "throws InvalidLength" $ + property $ \n slug -> (n < 1) ==> + truncateSlug n slug `shouldThrow` (== InvalidLength n) + context "when required length is OK" $ + it "truncates to this length or one less" $ + property $ \n slug -> (n > 0) ==> do + t <- truncateSlug n slug + T.length (unSlug t) `shouldSatisfy` (<= n) ---------------------------------------------------------------------------- --- Properties of helper-functions +-- Helpers infix 4 ==== @@ -116,43 +131,5 @@ displayLeft :: Show a => Either a b -> Either String b displayLeft = either (Left . show) Right -prop_changeStops :: Text -> Property -prop_changeStops x = f x ==== g x - where f = mkSlug - g = mkSlug >=> mkSlug . unSlug - -prop_parsing0 :: Slug -> Property -prop_parsing0 s = parseSlug (unSlug s) === Just s - -prop_parsing1 :: Text -> Property -prop_parsing1 x = (unSlug <$> mkSlug x) `notElem` [Nothing, Just x] - ==> parseSlug x ==== throwM (InvalidSlug x) - -prop_truncation :: Int -> Slug -> Property -prop_truncation n s = - case truncateSlug n s of - Left e -> n < 1 ==> show e === show (InvalidLength n) - Right t -> n > 0 ==> T.length (unSlug t) <= n - -prop_read0 :: Slug -> Property -prop_read0 s = read (show s) === s - -prop_read1 :: Text -> Property -prop_read1 s = isNothing (parseSlug s) - ==> (reads (show s) :: [(Slug, String)]) === [] - ----------------------------------------------------------------------------- --- Additional properties - -prop_showSlug :: Slug -> Property -prop_showSlug s = show s === show (unSlug s) - -prop_needAlphaNum :: Text -> Property -prop_needAlphaNum x = hasAlphaNum x ==> isJust (mkSlug x) - where hasAlphaNum = isJust . T.find isAlphaNum - -prop_pathPiece :: Text -> Property -prop_pathPiece x = - case mkSlug x of - Nothing -> property True - Just slug -> fromPathPiece (unSlug slug) === Just slug +instance Arbitrary Text where + arbitrary = T.pack <$> arbitrary