mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-01-18 07:01:55 +01:00
Move tag part of slugs into own module, make tag banning use it (#34)
This commit is contained in:
parent
41a9160c19
commit
190fef7adc
11
Data/Tag.hs
Normal file
11
Data/Tag.hs
Normal file
@ -0,0 +1,11 @@
|
|||||||
|
-- | A wrapper around the 'Slug' interface.
|
||||||
|
|
||||||
|
module Data.Tag where
|
||||||
|
|
||||||
|
import Control.Monad.Catch
|
||||||
|
import Data.Slug
|
||||||
|
import Data.Text
|
||||||
|
|
||||||
|
-- | Make a tag.
|
||||||
|
mkTag :: MonadThrow m => Text -> m Slug
|
||||||
|
mkTag = mkSlugLen 1 20
|
||||||
@ -1,11 +1,12 @@
|
|||||||
module Handler.BannedTags where
|
module Handler.BannedTags where
|
||||||
|
|
||||||
|
import Data.Slug (unSlug, Slug)
|
||||||
|
import Data.Tag
|
||||||
import Import
|
import Import
|
||||||
import Data.Slug (unSlug, mkSlug, Slug)
|
|
||||||
|
|
||||||
checkSlugs :: Monad m => Textarea -> m (Either Text [Slug])
|
checkSlugs :: Monad m => Textarea -> m (Either Text [Slug])
|
||||||
checkSlugs (Textarea t) =
|
checkSlugs (Textarea t) =
|
||||||
return $ first tshow $ (mapM mkSlug $ filter (not . null) $ lines $ filter (/= '\r') t)
|
return $ first tshow $ (mapM mkTag $ filter (not . null) $ lines $ filter (/= '\r') t)
|
||||||
|
|
||||||
fromSlugs :: [Slug] -> Textarea
|
fromSlugs :: [Slug] -> Textarea
|
||||||
fromSlugs = Textarea . unlines . map unSlug
|
fromSlugs = Textarea . unlines . map unSlug
|
||||||
|
|||||||
@ -5,7 +5,7 @@
|
|||||||
module Handler.Package where
|
module Handler.Package where
|
||||||
|
|
||||||
import Data.Char
|
import Data.Char
|
||||||
import Data.Slug
|
import Data.Tag
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import qualified Data.Text.Encoding as T
|
import qualified Data.Text.Encoding as T
|
||||||
import Data.Time (addUTCTime)
|
import Data.Time (addUTCTime)
|
||||||
@ -200,7 +200,7 @@ postPackageTagR packageName =
|
|||||||
do mtag <- lookupPostParam "slug"
|
do mtag <- lookupPostParam "slug"
|
||||||
case mtag of
|
case mtag of
|
||||||
Just tag ->
|
Just tag ->
|
||||||
do slug <- mkSlugLen 1 20 tag
|
do slug <- mkTag tag
|
||||||
void (runDB (P.insert (Tag packageName slug uid)))
|
void (runDB (P.insert (Tag packageName slug uid)))
|
||||||
Nothing -> error "Need a slug"
|
Nothing -> error "Need a slug"
|
||||||
|
|
||||||
@ -214,7 +214,7 @@ postPackageUntagR packageName =
|
|||||||
do mtag <- lookupPostParam "slug"
|
do mtag <- lookupPostParam "slug"
|
||||||
case mtag of
|
case mtag of
|
||||||
Just tag ->
|
Just tag ->
|
||||||
do slug <- mkSlugLen 1 20 tag
|
do slug <- mkTag tag
|
||||||
void (runDB (P.deleteWhere
|
void (runDB (P.deleteWhere
|
||||||
[TagPackage ==. packageName
|
[TagPackage ==. packageName
|
||||||
,TagTag ==. slug
|
,TagTag ==. slug
|
||||||
|
|||||||
@ -22,6 +22,7 @@ library
|
|||||||
Settings.StaticFiles
|
Settings.StaticFiles
|
||||||
Settings.Development
|
Settings.Development
|
||||||
Data.Slug
|
Data.Slug
|
||||||
|
Data.Tag
|
||||||
Data.BlobStore
|
Data.BlobStore
|
||||||
Data.Hackage
|
Data.Hackage
|
||||||
Data.Hackage.Views
|
Data.Hackage.Views
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user