slug (empty) → 0.1.0
raw patch · 7 files changed
+387/−0 lines, 7 filesdep +HUnitdep +QuickCheckdep +aesonsetup-changed
Dependencies added: HUnit, QuickCheck, aeson, base, exceptions, path-pieces, persistent, slug, test-framework, test-framework-hunit, test-framework-quickcheck2, text
Files
- CHANGELOG.md +3/−0
- LICENSE.md +28/−0
- README.md +58/−0
- Setup.hs +6/−0
- Web/Slug.hs +105/−0
- slug.cabal +92/−0
- tests/Main.hs +95/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+## Slug 0.1.0++* Initial release.
+ LICENSE.md view
@@ -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.
+ README.md view
@@ -0,0 +1,58 @@+# Slug++[](http://opensource.org/licenses/BSD-3-Clause)+[](https://hackage.haskell.org/package/slug)+[](http://stackage.org/nightly/package/slug)+[](https://travis-ci.org/mrkkrp/slug)+[](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.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ Web/Slug.hs view
@@ -0,0 +1,105 @@+-- |+-- Module : Web.Slug+-- Copyright : © 2015 Mark Karpov+-- License : BSD 3 clause+--+-- Maintainer : Mark Karpov <markkarpov@openmailbox.org>+-- 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
+ slug.cabal view
@@ -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 <markkarpov@opmbx.org>+maintainer: Mark Karpov <markkarpov@opmbx.org>+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
+ tests/Main.hs view
@@ -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