initial commit

.gitignore

@@ -0,0 +1,16 @@
+*#
+*.chi
+*.chs.h
+*.hi
+*.o
+*~
+.cabal-sandbox/
+.hsenv
+.stack-work/
+.virtualenv
+TAGS
+benchmarks.tix
+cabal-dev
+cabal.config
+cabal.sandbox.config
+dist/

.travis.yml

@@ -0,0 +1,51 @@
+language: c
+
+sudo: false
+
+matrix:
+  include:
+    - env: CABALVER=1.16 GHCVER=7.6.3
+      addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3,libtagc0-dev], sources: [hvr-ghc]}}
+    - env: CABALVER=1.18 GHCVER=7.8.4
+      addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,libtagc0-dev], sources: [hvr-ghc]}}
+    - env: CABALVER=1.22 GHCVER=7.10.1
+      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1,libtagc0-dev],sources: [hvr-ghc]}}
+    - env: CABALVER=1.22 GHCVER=7.10.2
+      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,libtagc0-dev],sources: [hvr-ghc]}}
+    - env: CABALVER=1.22 GHCVER=7.10.3
+      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,libtagc0-dev],sources: [hvr-ghc]}}
+    - env: CABALVER=head GHCVER=head
+      addons: {apt: {packages: [cabal-install-head,ghc-head,libtagc0-dev],  sources: [hvr-ghc]}}
+
+  allow_failures:
+    - env: CABALVER=head GHCVER=head
+
+before_install:
+  - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
+
+install:
+ - cabal --version
+ - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
+ - travis_retry cabal update
+ - cabal install --only-dependencies --enable-tests
+
+script:
+ - case "$CABALVER" in
+    "1.16") cabal configure --enable-tests -v2 -f dev ;;
+    "1.18") cabal configure --enable-tests --enable-library-coverage -v2 -f dev ;;
+    *)      cabal configure --enable-tests --enable-coverage -v2 -f dev ;;
+   esac
+ - cabal build
+ - cabal test --show-details=always
+ - cabal sdist
+ - cabal haddock | grep "100%" | wc -l | grep "1"
+
+after_script:
+ - cabal install hpc-coveralls
+ - export PATH=~/.cabal/bin:$PATH
+ - hpc-coveralls --coverage-mode=StrictlyFullLines
+                 --exclude-dir=tests
+                 tests
+
+notifications:
+  email: false

CHANGELOG.md

@@ -0,0 +1,3 @@
+## Slug 0.1.0
+
+* Initial release.

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.

README.md

@@ -0,0 +1,43 @@
+# 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.
+
+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
+```
+
+## License
+
+Copyright © 2015 Mark Karpov
+
+Distributed under BSD 3 clause license.

Setup.hs

@@ -0,0 +1,6 @@
+module Main (main) where
+
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain

Web/Slug.hs

@@ -0,0 +1,104 @@
+-- |
+-- 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.
+
+module Web.Slug
+  ( Slug
+  , mkSlug
+  , unSlug
+  , SlugException (..) )
+where
+
+import Control.Applicative (empty)
+import Control.Exception (Exception)
+import Control.Monad ((>=>))
+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 and 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 empty pure (mkSlug v)
+  parseJSON _            = empty
+
+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

@@ -0,0 +1,83 @@
+-- -*- 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
+  build-depends:       base >= 4.6 && < 5
+  default-language:    Haskell2010
+
+source-repository head
+  type:                git
+  location:            https://github.com/mrkkrp/slug.git

stack.yaml

@@ -0,0 +1,3 @@
+resolver: lts-3.9
+packages:
+- '.'

tests/Main.hs

@@ -0,0 +1,4 @@
+module Main (main) where
+
+main :: IO ()
+main = undefined