diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +## Slug 0.1.0 + +* Initial release. diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,28 @@ +Copyright © 2015 Mark Karpov + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +* 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. + +* Neither the name Mark Karpov nor the names of 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 “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 HOLDERS 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,58 @@ +# Slug + +[![License BSD3](https://img.shields.io/badge/license-BSD3-brightgreen.svg)](http://opensource.org/licenses/BSD-3-Clause) +[![Hackage](https://img.shields.io/hackage/v/slug.svg?style=flat)](https://hackage.haskell.org/package/slug) +[![Stackage Nightly](http://stackage.org/package/slug/badge/nightly)](http://stackage.org/nightly/package/slug) +[![Build Status](https://travis-ci.org/mrkkrp/slug.svg?branch=master)](https://travis-ci.org/mrkkrp/slug) +[![Coverage Status](https://coveralls.io/repos/mrkkrp/slug/badge.svg?branch=master&service=github)](https://coveralls.io/github/mrkkrp/slug?branch=master) + +This is [slug](https://en.wikipedia.org/wiki/Semantic_URL#Slug) +implementation that plays nicely with [Yesod](http://www.yesodweb.com/) +ecosystem. Although it's fairly easy to write this thing, slugs are useful +and general enough to be coded once and be used again and again. So this +little package eliminates some boilerplate you might find yourself writing. + +## 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 +works with `aeson` package. + +The slugs are completely type-safe. When you have a `Slug`, you can be sure +that there is a valid slug inside. Valid slug has the following qualities: + +* it's not empty; + +* it consists only of alpha-numeric groups of characters (words) separated + by `'-'` dashes in such a way that entire slug cannot start or end in a + dash and also two dashes in a row cannot be found; + +* every character with defined notion of case is lower-cased. + +To use the package with persistent models, just import `Web.Slug` and add it +to model file: + +``` +MyEntity + slug Slug + … +``` + +Use it in route file like this: + +``` +/post/#Slug PostR GET +``` + +In Haskell code, create slugs from `Text` with `mkSlug` and extract their +textual representation with `unSlug`. The following property holds: + +```haskell +mkSlug = mkSlug >=> mkSlug . unSlug +``` + +## License + +Copyright © 2015 Mark Karpov + +Distributed under BSD 3 clause license. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/Web/Slug.hs b/Web/Slug.hs new file mode 100644 --- /dev/null +++ b/Web/Slug.hs @@ -0,0 +1,105 @@ +-- | +-- Module : Web.Slug +-- Copyright : © 2015 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Type-safe slug implementation for Yesod ecosystem. + +{-# LANGUAGE DeriveDataTypeable #-} + +module Web.Slug + ( Slug + , mkSlug + , unSlug + , SlugException (..) ) +where + +import Control.Exception (Exception) +import Control.Monad (mzero, (>=>)) +import Control.Monad.Catch (MonadThrow (..)) +import Data.Aeson.Types (ToJSON (..), FromJSON (..)) +import Data.Char (isAlphaNum) +import Data.Text (Text) +import Data.Typeable (Typeable) +import Database.Persist.Class (PersistField (..)) +import Database.Persist.Sql (PersistFieldSql (..)) +import Database.Persist.Types (SqlType (..)) +import Web.PathPieces +import qualified Data.Aeson.Types as A +import qualified Data.Text as T + +-- | This exception is thrown by 'mkSlug' when its input cannot be converted +-- into proper 'Slug'. + +data SlugException = InvalidInput Text deriving (Typeable) + +instance Show SlugException where + show (InvalidInput text) = "Cannot build slug for " ++ show text + +instance Exception SlugException + +-- | Slug. Textual value inside is always guaranteed to have the following +-- qualities: +-- +-- * it's not empty; +-- * it consists only of alpha-numeric groups of characters (words) +-- separated by @\'-\'@ dashes in such a way that entire slug cannot +-- start or end in a dash and also two dashes in a row cannot be found; +-- * every character with defined notion of case is lower-cased. +-- +-- Slugs are good for semantic URLs and also can be used as identifier of a +-- sort in some cases. + +newtype Slug = Slug + { unSlug :: Text -- ^ Get textual representation of 'Slug'. + } deriving (Eq, Show, 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'. +-- +-- This function also have a useful property: +-- +-- > mkSlug = mkSlug >=> mkSlug . unSlug + +mkSlug :: MonadThrow m => Text -> m Slug +mkSlug text = + let ws = getSlugWords text + in if null ws + then throwM (InvalidInput text) + else return . Slug . T.intercalate "-" $ ws + +-- | Convert 'Text' to possibly empty collection of words. Every word is +-- guaranteed to be non-empty alpha-numeric lowercased sequence of +-- characters. + +getSlugWords :: Text -> [Text] +getSlugWords = T.words . T.toLower . T.map f . T.replace "'" "" + where f x = if isAlphaNum x then x else ' ' + +instance ToJSON Slug where + toJSON = toJSON . unSlug + +instance FromJSON Slug where + parseJSON (A.String v) = maybe mzero return (mkSlug v) + parseJSON _ = mzero + +instance PersistField Slug where + toPersistValue = toPersistValue . unSlug + fromPersistValue = + fromPersistValue >=> either (Left . T.pack . show) Right . mkSlug + +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 diff --git a/slug.cabal b/slug.cabal new file mode 100644 --- /dev/null +++ b/slug.cabal @@ -0,0 +1,92 @@ +-- -*- Mode: Haskell-Cabal; -*- +-- +-- Cabal configuration for ‘slug’. +-- +-- Copyright © 2015 Mark Karpov +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- * 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. +-- +-- * Neither the name Mark Karpov nor the names of 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 “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 HOLDERS 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. + +name: slug +version: 0.1.0 +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 +category: Web +synopsis: Type-safe slugs for Yesod ecosystem +build-type: Simple +description: Type-safe slugs for Yesod ecosystem. +extra-source-files: CHANGELOG.md + , README.md + +flag dev + description: Turn on development settings. + manual: True + default: False + +library + build-depends: aeson >= 0.8 + , base >= 4.6 && < 5 + , exceptions >= 0.6 + , path-pieces >= 0.1.5 + , persistent >= 2.0 + , text >= 1.0 + default-extensions: OverloadedStrings + exposed-modules: Web.Slug + if flag(dev) + ghc-options: -Wall -Werror + else + ghc-options: -O2 -Wall + default-language: Haskell2010 + +test-suite tests + main-is: Main.hs + hs-source-dirs: tests + type: exitcode-stdio-1.0 + if flag(dev) + ghc-options: -Wall -Werror + else + ghc-options: -O2 -Wall + default-extensions: OverloadedStrings + build-depends: QuickCheck >= 2.4 && < 3 + , HUnit >= 1.2 && < 1.4 + , base >= 4.6 && < 5 + , path-pieces >= 0.1.5 + , slug >= 0.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 + +source-repository head + type: git + location: https://github.com/mrkkrp/slug.git diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,95 @@ +-- -*- Mode: Haskell; -*- +-- +-- Slug tests. +-- +-- Copyright © 2015 Mark Karpov +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- * 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. +-- +-- * Neither the name Mark Karpov nor the names of 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 “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 HOLDERS 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. + +{-# LANGUAGE CPP #-} +{-# OPTIONS -fno-warn-orphans #-} + +module Main (main) where + +import Control.Monad ((>=>)) +import Data.Char (isAlphaNum) +import Data.Maybe (isJust) +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 +import qualified Data.Text as T + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif + +main :: IO () +main = defaultMain [tests] + +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 + , 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 + +prop_changeStops :: Text -> Property +prop_changeStops x = v (f x) === v (g x) + where f = mkSlug + g = mkSlug >=> mkSlug . unSlug + v = either (Left . show) Right + +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 + +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