module Web.Slug
( Slug
, mkSlug
, unSlug
, parseSlug
, truncateSlug
, SlugException (..) )
where
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.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 as A
import qualified Data.Text as T
data SlugException
= InvalidInput Text
| InvalidSlug Text
| InvalidLength Int
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
newtype Slug = Slug Text deriving (Eq, Ord, Data, Typeable)
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
unSlug :: Slug -> Text
unSlug (Slug x) = x
getSlugWords :: Text -> [Text]
getSlugWords = T.words . T.toLower . T.map f . T.replace "'" ""
where f x = if isAlphaNum x then x else ' '
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)
truncateSlug :: MonadThrow m
=> Int
-> Slug
-> m 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.withText "Slug" $ \txt ->
case parseSlug txt of
Left err -> fail (show err)
Right val -> return val
instance PersistField Slug where
toPersistValue = toPersistValue . unSlug
fromPersistValue =
fromPersistValue >=> either (Left . T.pack . show) Right . parseSlug
instance PersistFieldSql Slug where
sqlType = const SqlString
instance PathPiece Slug where
fromPathPiece = parseSlug
toPathPiece = unSlug