module Web.Slug
( Slug
, mkSlug
, unSlug
, parseSlug
, truncateSlug
, SlugException (..) )
where
import Control.Exception (Exception (..))
import Control.Monad
import Control.Monad.Catch (MonadThrow (..))
import Data.Aeson.Types (ToJSON (..), FromJSON (..))
import Data.Char (isAlphaNum)
import Data.Data (Data)
import Data.Maybe (isJust, fromJust)
import Data.Semigroup
import Data.Text (Text)
import Data.Typeable (Typeable)
import Database.Persist.Class (PersistField (..))
import Database.Persist.Sql (PersistFieldSql (..))
import Database.Persist.Types (SqlType (..))
import Test.QuickCheck
import Web.HttpApiData
import Web.PathPieces
import qualified Data.Aeson as A
import qualified Data.Text as T
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
data SlugException
= InvalidInput Text
| InvalidSlug Text
| InvalidLength Int
deriving (Eq, Show, Typeable)
instance Exception SlugException where
#if MIN_VERSION_base(4,8,0)
displayException (InvalidInput text) = "Cannot build slug for " ++ show text
displayException (InvalidSlug text) = "The text is not a valid slug " ++ show text
displayException (InvalidLength n) = "Invalid slug length: " ++ show n
#endif
newtype Slug = Slug Text deriving (Eq, Ord, Data, Typeable)
instance Semigroup Slug where
x <> y = Slug (unSlug x <> "-" <> unSlug y)
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 . f) Right . parseSlug
where
#if MIN_VERSION_base(4,8,0)
f = displayException
#else
f = show
#endif
instance PersistFieldSql Slug where
sqlType = const SqlString
instance PathPiece Slug where
fromPathPiece = parseSlug
toPathPiece = unSlug
instance ToHttpApiData Slug where
toUrlPiece = unSlug
instance FromHttpApiData Slug where
parseUrlPiece = either (Left . T.pack . f) Right . parseSlug
where
#if MIN_VERSION_base(4,8,0)
f = displayException
#else
f = show
#endif
instance Arbitrary Slug where
arbitrary = fromJust <$> (mkSlug . T.pack <$> arbitrary) `suchThat` isJust