diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,12 @@ +## Slug 0.1.1 + +* Add `Read` instance of `Slug`. + +* Add `parseSlug` and `truncateSlug` functions. + +* Functions (including instance methods) that parse `Text` that must be + formatted as valid slug are case-sensitive now. + ## Slug 0.1.0 * Initial release. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -15,7 +15,7 @@ ## Quick start The package provides data type `Slug` that is instance of various type -classes, so it can be used with Persistent or as part of route. It's also +classes, so it can be used with Persistent or as part of route. It also works with `aeson` package. The slugs are completely type-safe. When you have a `Slug`, you can be sure diff --git a/Web/Slug.hs b/Web/Slug.hs --- a/Web/Slug.hs +++ b/Web/Slug.hs @@ -10,16 +10,19 @@ -- Type-safe slug implementation for Yesod ecosystem. {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TupleSections #-} module Web.Slug ( Slug , mkSlug , unSlug + , parseSlug + , truncateSlug , SlugException (..) ) where import Control.Exception (Exception) -import Control.Monad (mzero, (>=>)) +import Control.Monad (mzero, (>=>), liftM) import Control.Monad.Catch (MonadThrow (..)) import Data.Aeson.Types (ToJSON (..), FromJSON (..)) import Data.Char (isAlphaNum) @@ -35,10 +38,16 @@ -- | This exception is thrown by 'mkSlug' when its input cannot be converted -- into proper 'Slug'. -data SlugException = InvalidInput Text deriving (Typeable) +data SlugException + = 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 instance Exception SlugException @@ -56,14 +65,15 @@ newtype Slug = Slug { unSlug :: Text -- ^ Get textual representation of 'Slug'. - } deriving (Eq, Show, Typeable) + } deriving (Eq, Typeable) -- | Create 'Slug' from 'Text', all necessary transformations are -- applied. Argument of this function can be title of an article or -- something like that. -- -- Note that result is inside 'MonadThrow', that means you can just get it --- in 'Maybe', in more complex contexts it will throw 'SlugException'. +-- in 'Maybe', in more complex contexts it will throw 'SlugException' +-- exception using 'InvalidInput' constructor. -- -- This function also have a useful property: -- @@ -84,22 +94,56 @@ getSlugWords = T.words . T.toLower . T.map f . T.replace "'" "" where f x = if isAlphaNum x then x else ' ' +-- | Convert 'Text' into 'Slug' only when it is already valid slug. +-- +-- This function can throw 'SlugException' exception using 'InvalidSlug' +-- constructor. + +parseSlug :: MonadThrow m => Text -> m Slug +parseSlug v = mkSlug v >>= check + where check s = + if unSlug s == v + then return s + else throwM (InvalidSlug v) + +-- | Ensure that given 'Slug' is not longer than given maximum number of +-- characters. If truncated slug ends in a dash, remove that dash too. (Dash +-- at the end would violate properties described in documentation for +-- 'Slug'.) +-- +-- If the first argument is not a positive number, 'SlugException' is thrown +-- using 'InvalidLength' constructor. + +truncateSlug :: MonadThrow m + => Int -- ^ Maximum length of slug, must be greater than 0 + -> Slug -- ^ Original non-truncated slug + -> m Slug -- ^ Truncated slug +truncateSlug n v + | n < 1 = throwM (InvalidLength n) + | otherwise = mkSlug . T.take n . unSlug $ v + +instance Show Slug where + show = show . unSlug + +instance Read Slug where + readsPrec n = (readsPrec n :: ReadS Text) >=> f + where f (s, t) = (,t) `liftM` parseSlug s + instance ToJSON Slug where toJSON = toJSON . unSlug instance FromJSON Slug where - parseJSON (A.String v) = maybe mzero return (mkSlug v) + parseJSON (A.String v) = maybe mzero return (parseSlug v) parseJSON _ = mzero instance PersistField Slug where toPersistValue = toPersistValue . unSlug fromPersistValue = - fromPersistValue >=> either (Left . T.pack . show) Right . mkSlug + fromPersistValue >=> either (Left . T.pack . show) Right . parseSlug instance PersistFieldSql Slug where sqlType = const SqlString instance PathPiece Slug where - fromPathPiece v = mkSlug v >>= check - where check s = if unSlug s == T.toLower v then Just s else Nothing - toPathPiece = unSlug + fromPathPiece = parseSlug + toPathPiece = unSlug diff --git a/slug.cabal b/slug.cabal --- a/slug.cabal +++ b/slug.cabal @@ -32,14 +32,14 @@ -- POSSIBILITY OF SUCH DAMAGE. name: slug -version: 0.1.0 +version: 0.1.1 cabal-version: >= 1.10 license: BSD3 license-file: LICENSE.md author: Mark Karpov maintainer: Mark Karpov -homepage: https://github.com/mrkkrp/htaglib -bug-reports: https://github.com/mrkkrp/htaglib/issues +homepage: https://github.com/mrkkrp/slug +bug-reports: https://github.com/mrkkrp/slug/issues category: Web synopsis: Type-safe slugs for Yesod ecosystem build-type: Simple @@ -77,12 +77,11 @@ ghc-options: -O2 -Wall default-extensions: OverloadedStrings build-depends: QuickCheck >= 2.4 && < 3 - , HUnit >= 1.2 && < 1.4 , base >= 4.6 && < 5 + , exceptions >= 0.6 , path-pieces >= 0.1.5 - , slug >= 0.1 + , slug >= 0.1.1 , test-framework >= 0.6 && < 1 - , test-framework-hunit >= 0.2 && < 0.4 , test-framework-quickcheck2 >= 0.3 && < 0.4 , text >= 1.0 default-language: Haskell2010 diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -37,13 +37,13 @@ module Main (main) where import Control.Monad ((>=>)) -import Data.Char (isAlphaNum) -import Data.Maybe (isJust) +import Control.Monad.Catch (MonadThrow (..)) +import Data.Char (isAlphaNum, isUpper) +import Data.Function (on) +import Data.Maybe (fromJust, isJust, isNothing) import Data.Text (Text) import Test.Framework -import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit hiding (Test, path) import Test.QuickCheck import Web.PathPieces import Web.Slug @@ -58,23 +58,96 @@ tests :: Test tests = testGroup "Slug properties" - [ testProperty "Slug of slug is the slug" prop_changeStops - , testProperty "Alpha-numeric chars are necessary and sufficient" - prop_needAlphaNum + [ -- 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 - , testCase "Removal of apostrophe" prop_apostropheRemoval - , testCase "Path pieces ignore case of slugs" prop_pathPieceCase ] 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 + +prop_noUpperCase :: Slug -> Property +prop_noUpperCase = expectFailure . T.any isUpper . unSlug + +---------------------------------------------------------------------------- +-- Properties of helper-functions + +infix 4 ==== + +(====) :: (Show a, Show b, Eq b) => Either a b -> Either a b -> Property +(====) = (===) `on` displayLeft + +displayLeft :: Show a => Either a b -> Either String b +displayLeft = either (Left . show) Right + prop_changeStops :: Text -> Property -prop_changeStops x = v (f x) === v (g x) +prop_changeStops x = f x ==== g x where f = mkSlug g = mkSlug >=> mkSlug . unSlug - v = either (Left . show) Right +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 @@ -84,12 +157,3 @@ case mkSlug x of Nothing -> property True Just slug -> fromPathPiece (unSlug slug) === Just slug - -prop_apostropheRemoval :: Assertion -prop_apostropheRemoval = unSlug <$> mkSlug text @?= Just slug - where text = "That's what I thought about doin' that stuff!" - slug = "thats-what-i-thought-about-doin-that-stuff" - -prop_pathPieceCase :: Assertion -prop_pathPieceCase = fromPathPiece text @?= mkSlug text - where text = "thiS-Строка-hAs-коМбиНацию-of-DiffErent-Cases" :: Text