diff --git a/eros.cabal b/eros.cabal --- a/eros.cabal +++ b/eros.cabal @@ -1,5 +1,5 @@ name: eros -version: 0.1.0.0 +version: 0.2.0.0 synopsis: A text censorship library. description: A Haskell library for censoring text, using @@ -11,7 +11,6 @@ There exist compressed versions, for use within your code. You can see the compressed versions . - homepage: https://eros.valkyrian.com/ license: BSD3 license-file: LICENSE @@ -21,7 +20,9 @@ category: Text build-type: Simple data-files: - res/phraselist-schema.json + res/schemata/erosc-input.json + res/schemata/erosc-output.json + res/schemata/phraselist.json res/phraselists-ugly/chat.json res/phraselists-ugly/conspiracy.json res/phraselists-ugly/drug-advocacy.json @@ -56,9 +57,10 @@ library exposed-modules: Text.Eros.Message - Text.Eros.Phrase - Text.Eros.Phraselist - -- other-modules: + , Text.Eros.Phrase + , Text.Eros.Phraselist + other-modules: + Paths_eros other-extensions: FlexibleInstances , OverloadedStrings @@ -68,7 +70,7 @@ , bytestring , containers , text - hs-source-dirs: src/ + hs-source-dirs: src/lib/ default-language: Haskell2010 Test-Suite test-phrase @@ -83,8 +85,23 @@ , eros , QuickCheck , text + default-language: Haskell2010 +executable erosc + build-depends: + aeson + , aeson-pretty + , base >=4.7 && <4.8 + , bytestring + , containers + , eros + , text + hs-source-dirs: src/erosc/ + main-is: Main.hs + default-language: Haskell2010 + source-repository head type: git location: https://github.com/pharpend/eros.git branch: master + tag: v.0.2 diff --git a/res/phraselist-schema.json b/res/phraselist-schema.json deleted file mode 100644 --- a/res/phraselist-schema.json +++ /dev/null @@ -1,27 +0,0 @@ -{ - "name": "PhraseList", - "type": "array", - "items": { - "type": "object", - "properties": { - "phrase": { - "type": "string", - "description": "the phrase", - "required": true - }, - "score": { - "type": "number", - "description": "The phrase's score.", - "required": true - }, - "forest": { - "type": "array", - "description": "Subsequent phrases.", - "required": true, - "items": { - "type": "object" - } - } - } - } -} diff --git a/res/schemata/erosc-input.json b/res/schemata/erosc-input.json new file mode 100644 --- /dev/null +++ b/res/schemata/erosc-input.json @@ -0,0 +1,20 @@ +{ + "name": "erosc-input", + "type": "object", + "description": "The schema for the input to erosc.", + "properties": { + "text": { + "type": "string", + "description": "The text you want to be checked against the phraselists.", + "required": true + }, + "eros-lists": { + "type": "array", + "description": "The phraselists provided by eros you want \"text\" to be checked against.", + "required": true, + "items": { + "type": "string" + } + }, + } +} diff --git a/res/schemata/erosc-output.json b/res/schemata/erosc-output.json new file mode 100644 --- /dev/null +++ b/res/schemata/erosc-output.json @@ -0,0 +1,19 @@ +{ + "name": "erosc-output", + "type": "array", + "description": "The output of erosc.", + "items": { + "type": "object", + "description": "The phraselist name, along with the score for that phraselist.", + "properties": { + "eros-list": { + "type": "string", + "description": "The name of the phraselist corresponding to this object." + }, + "score": { + "type": "number", + "description": "The score corresponding to this phraselist." + } + } + } +} diff --git a/res/schemata/phraselist.json b/res/schemata/phraselist.json new file mode 100644 --- /dev/null +++ b/res/schemata/phraselist.json @@ -0,0 +1,27 @@ +{ + "name": "phraselist", + "type": "array", + "items": { + "type": "object", + "properties": { + "phrase": { + "type": "string", + "description": "the phrase", + "required": true + }, + "score": { + "type": "number", + "description": "The phrase's score.", + "required": true + }, + "forest": { + "type": "array", + "description": "Subsequent phrases.", + "required": true, + "items": { + "type": "object" + } + } + } + } +} diff --git a/src/Text/Eros/Message.hs b/src/Text/Eros/Message.hs deleted file mode 100644 --- a/src/Text/Eros/Message.hs +++ /dev/null @@ -1,61 +0,0 @@ --- | --- Module : Text.Eros.Message --- Description : Module for censoring pieces of text. --- Copyright : 2014, Peter Harpending --- License : BSD3 --- Maintainer : Peter Harpending --- Stability : experimental --- Portability : archlinux - --- This module deals specifically with pieces of 'Text'. - -module Text.Eros.Message (messageScore) where - --- Here, we have all the imports. -import Data.List -import qualified Data.Map.Strict as M -import qualified Data.Text.Lazy as L -import Data.Tree -import Text.Eros.Phrase -import Text.Eros.Phraselist - - --- |I can never remember what I named things, so here are a bunch of --- type synonyms. -type BadWord = L.Text -type Message = L.Text -type MessagePart = L.Text -type Restof = L.Text -type RestOf = L.Text -type Word = L.Text -type Score = Int - --- |Does a top-level split of a 'Message'. Returns a list of pairs, --- with the first element being the score up to that point in the --- message, as well as the rest of the message. That gives you --- somewhat of an idea how it works, but that's not quite it -messageSplit :: Message -> PhraseMap -> [(Score, RestOf)] -messageSplit initialText sayingsMap = concat $ filter (/= []) - $ nub - $ map breakSaying potentialSayings - where - potentialSayings = M.keys sayingsMap - breakSaying saying = map (trimSaying saying . snd) $ broked saying - trimSaying saying txt = (sayScore saying, L.strip $ L.drop (L.length saying) txt) - sayScore saying = case maybeScore saying of - Just score -> score - Nothing -> 0 - maybeScore saying = fmap score $ fmap rootLabel $ M.lookup saying sayingsMap - broked saying = L.breakOnAll saying lowerText -- looks like [("go ", "fuck yourself ")] - lowerText = L.toLower initialText -- looks like "go fuck yourself" (compared to "gO fUcK yOURSelf") - trimPair (a, b) = (L.strip a, L.strip b) -- looks like ("go", "fuck yourself") - --- |Given a message, find its score. -messageScore :: Message -> PhraseMap -> Score -messageScore msg pmap - | L.empty == msg = 0 - | otherwise = (sum topScores) + (sum lowerScores) - where - msgSplit = messageSplit msg pmap - topScores = map fst msgSplit - lowerScores = map (\m -> messageScore m pmap) $ map snd msgSplit diff --git a/src/Text/Eros/Phrase.hs b/src/Text/Eros/Phrase.hs deleted file mode 100644 --- a/src/Text/Eros/Phrase.hs +++ /dev/null @@ -1,57 +0,0 @@ --- | --- Module : Text.Eros.Phrase --- Description : Pure interface for 'Phrase's and 'PhraseTree's. --- Copyright : 2014, Peter Harpending. --- License : BSD3 --- Maintainer : Peter Harpending --- Stability : experimental --- Portability : archlinux --- - -module Text.Eros.Phrase where - -import qualified Data.Map as M -import Data.Ord (comparing) -import Data.Text.Lazy (Text) -import Data.Tree - --- |A Phrase is a piece of Text, with an int representing its --- weight. These are the used internally within 'eros', in --- 'Tree's. -data Phrase = Phrase { phrase :: Text - , score :: Int - } - deriving (Read, Show) - -instance Eq Phrase where - a == b = (score a) == (score b) - a /= b = (score a) /= (score b) - -instance Ord Phrase where - -- |To compare 'Phrases', just compare their 'score's - compare = comparing score - --- |A 'Tree' of 'Phrase's -type PhraseTree = Tree Phrase --- |A 'Forest' of 'Phrase's -type PhraseForest = Forest Phrase --- |A Map of text values the appropriate tree -type PhraseMap = M.Map Text PhraseTree - --- |The 'score' of the 'PhraseTree' is the sum of the 'score's of its 'Node's. -treeScore :: PhraseTree -> Int -treeScore = sum . map score . flatten - --- |Given a list of 'PhraseTree's, return the top-level 'phrase's. -forestPhrases :: [PhraseTree] -> [Text] -forestPhrases = map forestPhrase - --- |Given a 'PhraseTree', return the top-level 'phrase'. -forestPhrase :: PhraseTree -> Text -forestPhrase (Node phr subf) = phrase phr - --- |Given a list of 'PhraseTree's, return a map of each phrase with --- the appropriate tree. -mkMap :: PhraseForest -> PhraseMap -mkMap = M.fromList . phraseTreeAlist - where phraseTreeAlist frs = zip (forestPhrases frs) frs diff --git a/src/Text/Eros/Phraselist.hs b/src/Text/Eros/Phraselist.hs deleted file mode 100644 --- a/src/Text/Eros/Phraselist.hs +++ /dev/null @@ -1,227 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} - --- | --- Module : Text.Eros.Phraselist --- Description : A module for dealing with Phraselists. --- Copyright : 2014, Peter Harpending. --- License : BSD3 --- Maintainer : Peter Harpending --- Stability : experimental --- Portability : archlinux --- --- If you want to make your own phraselist, you need to write a JSON --- file, in accordance with the --- . --- Once you do that, make a data type for your phraselist. --- Make your data type an instance of 'Phraselist', and you're good to --- go. --- --- For example, let's say your phraselist is @mylist.json@, and it's --- all in accordance with the schema. Your code would look something --- like this: --- --- @ --- data MyList = MyList --- --- instance Phraselist MyList where --- phraselistPath MyList = getDataFileName "mylist.json" --- phraselistPath _ = undefined --- @ --- --- Don't forget to add @mylist.json@ to @Data-Files@ in your @.cabal@ --- file. --- --- If you want to use one of the lists we already supply --- - -module Text.Eros.Phraselist where - -import Control.Applicative ((<$>), (<*>)) -import Control.Monad (mzero, sequence) -import Data.Aeson -import qualified Data.ByteString.Lazy as B -import Data.Text.Lazy (Text) -import qualified Data.Text.Lazy as L -import Data.Tree -import Paths_eros -import System.Exit -import Text.Eros.Phrase - -class Phraselist t where - phraselistPath :: t -> IO FilePath - --- |A set of 'Phraselist's. Note that this is actually a list, and I'm --- calling it a "set" for purely lexical purposes. -type PhraselistSet = Phraselist t => [t] - --- |The phraselists in @res/@. Each of these constructors correspond --- to one of the files --- . --- --- Gitlab has a terrible interface, so I won't provide links to each --- one of them. -data ErosList = Chat - | Conspiracy - | DrugAdvocacy - | Forums - | Gambling - | Games - | Gore - | IdTheft - | IllegalDrugs - | Intolerance - | LegalDrugs - | Malware - | Music - | News - | Nudism - | Peer2Peer - | Personals - | Pornography - | Proxies - | SecretSocieties - | SelfLabeling - | Sport - | Translation - | UpstreamFilter - | Violence - | WarezHacking - | Weapons - | Webmail - --- |A list of phraselists we provide. -erosLists :: [ErosList] -erosLists = [ Chat - , Conspiracy - , DrugAdvocacy - , Forums - , Gambling - , Games - , Gore - , IdTheft - , IllegalDrugs - , Intolerance - , LegalDrugs - , Malware - , Music - , News - , Nudism - , Peer2Peer - , Personals - , Pornography - , Proxies - , SecretSocieties - , SelfLabeling - , Sport - , Translation - , UpstreamFilter - , Violence - , WarezHacking - , Weapons - , Webmail - ] - --- |A list of the paths to the phraselists we provide. -erosListPaths :: IO [FilePath] -erosListPaths = mapM phraselistPath erosLists - --- These are the data paths for the various PhraseLists -instance Phraselist ErosList where - phraselistPath Chat = getDataFileName "res/phraselists-ugly/chat.json" - phraselistPath Conspiracy = getDataFileName "res/phraselists-ugly/conspiracy.json" - phraselistPath DrugAdvocacy = getDataFileName "res/phraselists-ugly/drug-advocacy.json" - phraselistPath Forums = getDataFileName "res/phraselists-ugly/forums.json" - phraselistPath Gambling = getDataFileName "res/phraselists-ugly/gambling.json" - phraselistPath Games = getDataFileName "res/phraselists-ugly/games.json" - phraselistPath Gore = getDataFileName "res/phraselists-ugly/gore.json" - phraselistPath IdTheft = getDataFileName "res/phraselists-ugly/id-theft.json" - phraselistPath IllegalDrugs = getDataFileName "res/phraselists-ugly/illegal-drugs.json" - phraselistPath Intolerance = getDataFileName "res/phraselists-ugly/intolerance.json" - phraselistPath LegalDrugs = getDataFileName "res/phraselists-ugly/legal-drugs.json" - phraselistPath Malware = getDataFileName "res/phraselists-ugly/malware.json" - phraselistPath Music = getDataFileName "res/phraselists-ugly/music.json" - phraselistPath News = getDataFileName "res/phraselists-ugly/news.json" - phraselistPath Nudism = getDataFileName "res/phraselists-ugly/nudism.json" - phraselistPath Peer2Peer = getDataFileName "res/phraselists-ugly/peer2peer.json" - phraselistPath Personals = getDataFileName "res/phraselists-ugly/personals.json" - phraselistPath Pornography = getDataFileName "res/phraselists-ugly/pornography.json" - phraselistPath Proxies = getDataFileName "res/phraselists-ugly/proxies.json" - phraselistPath SecretSocieties = getDataFileName "res/phraselists-ugly/secret-societies.json" - phraselistPath SelfLabeling = getDataFileName "res/phraselists-ugly/self-labeling.json" - phraselistPath Sport = getDataFileName "res/phraselists-ugly/sport.json" - phraselistPath Translation = getDataFileName "res/phraselists-ugly/translation.json" - phraselistPath UpstreamFilter = getDataFileName "res/phraselists-ugly/upstream-filter.json" - phraselistPath Violence = getDataFileName "res/phraselists-ugly/violence.json" - phraselistPath WarezHacking = getDataFileName "res/phraselists-ugly/warez-hacking.json" - phraselistPath Weapons = getDataFileName "res/phraselists-ugly/weapons.json" - phraselistPath Webmail = getDataFileName "res/phraselists-ugly/webmail.json" - --- |Placeholder type used to read JSON. The JSON schema (currently, at --- least) is such that one needs this type to read the JSON. You can --- use 'fromPAT' to convert this type into a 'PhraseTree' -data PhraseAlmostTree = PhraseAlmostTree { patPhrase :: Text - , patScore :: Int - , patForest :: [PhraseAlmostTree] - } - deriving (Show, Read) - --- |Alias for 'PhraseAlmostTree' -type PAT = PhraseAlmostTree - --- |You can read the --- --- to see how this works. -instance FromJSON PAT where - parseJSON (Object v) = PhraseAlmostTree - <$> v .: "phrase" - <*> v .: "score" - <*> v .: "forest" - parseJSON _ = fail "Object not a PhraseAlmostTree." - --- |Convert a 'PAT' into a 'PhraseTree'. -fromPAT :: PAT -> PhraseTree -fromPAT (PhraseAlmostTree p s f) = Node (Phrase p s) $ map fromPAT f - --- |I figure some people like to type a lot. -fromPhraseAlmostTree :: PAT -> PhraseTree -fromPhraseAlmostTree = fromPAT - --- |Read a 'Phraselist', marshal it into a 'PhraseForest'. -readPhraselist :: Phraselist t => t -> IO PhraseForest -readPhraselist elist = do - lpath <- phraselistPath elist - ltext <- B.readFile lpath - let ljson = (eitherDecode ltext) :: Either String [PAT] - case ljson of - Left msg -> fail msg - Right pats -> return $ map fromPAT pats - --- |Alias for 'readPhraselist' -loadPhraselist :: Phraselist t => t -> IO PhraseForest -loadPhraselist = readPhraselist - --- |Alias for 'readPhraselist' -readPhraseFile :: Phraselist t => t -> IO PhraseForest -readPhraseFile = readPhraselist - --- |Alias for 'readPhraselist' -loadPhraseFile :: Phraselist t => t -> IO PhraseForest -loadPhraseFile = readPhraselist - --- |Alias for 'readPhraselist' -readPhraseForest :: Phraselist t => t -> IO PhraseForest -readPhraseForest = readPhraselist - --- |Alias for 'readPhraselist' -loadPhraseForest :: Phraselist t => t -> IO PhraseForest -loadPhraseForest = readPhraselist - --- |Load a 'Phraselist' directly into a 'PhraseMap' -readPhraseMap :: Phraselist t => t -> IO PhraseMap -readPhraseMap plist = fmap mkMap $ readPhraselist plist - --- |Alias for 'readPhraseMap' -loadPhraseMap :: Phraselist t => t -> IO PhraseMap -loadPhraseMap = readPhraseMap diff --git a/src/erosc/Main.hs b/src/erosc/Main.hs new file mode 100644 --- /dev/null +++ b/src/erosc/Main.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +-- |This is the main module for the eros client. This is not the meat & +-- potatoes of the program, but this is the bread & butter. +-- +module Main where + +import Control.Applicative +import Control.Monad (mzero) +import Data.Aeson +import Data.Aeson.Encode.Pretty +import qualified Data.ByteString.Lazy as LzByte +import qualified Data.Text.Lazy as LzText +import qualified Data.Text.Lazy.IO as LazyIO +import qualified Data.Map as M +import qualified System.IO as StdIO +import Text.Eros.Message +import Text.Eros.Phrase (mkMap) +import Text.Eros.Phraselist + +-- |It's convenient to think of Scores as Scores, although, they are truly ints. +type Score = Int + +-- |We represent the input data in its own data type. This is needed +-- for JSON parsing, but it will also be useful down the road, when I +-- allow input that isn't JSON. +data EroscInput = EroscInput { text :: LzText.Text + , erosLists :: [ErosList] + } + +-- |This is pretty self-explanatory +instance FromJSON ErosList where + parseJSON (String s) = case erosListByName (LzText.fromStrict s) of + Just list -> return list + Nothing -> mzero + parseJSON _ = mzero + +-- |This is pretty self-explanatory +instance FromJSON EroscInput where + parseJSON (Object v) = EroscInput + <$> v .: "text" + <*> v .: "eros-lists" + parseJSON _ = mzero + +-- |This is the output data type. I will make an instance of ToJSON +-- for this data type. Again, at the start, only JSON input and output +-- is existent. +data EroscOutput = EroscOutput { elScore :: [(ErosList, Score)] } + +-- |Pretty self-explanatory +instance ToJSON ErosList where + toJSON el = case erosNameByList el of + Just nom -> toJSON nom + Nothing -> "Well, something got fucked up." + +-- |Pretty self-explanatory +instance ToJSON (ErosList, Score) where + toJSON (el, sc) = object [ "eros-list" .= el + , "score" .= sc + ] + +-- |Pretty self-explanatory +instance ToJSON EroscOutput where + toJSON (EroscOutput elm) = toJSON elm + +erosEncode :: ToJSON a => a -> LzByte.ByteString +erosEncode = encodePretty' defConfig { confIndent = 2 + } + +main :: IO () +main = do + -- take the json from stdin, try to decode it + inputBt <- LzByte.hGetContents StdIO.stdin + let eitherJson = (eitherDecode inputBt) :: Either String EroscInput + -- if by chance, it isn't decoded, the program shall flip its shit + case eitherJson of + Left msg -> fail msg + Right ecInput -> runInput ecInput + +runInput :: EroscInput -> IO () +runInput ipt = do + result <- processInput ipt + let jsonText = erosEncode result + LzByte.hPutStr StdIO.stdout jsonText + +processInput :: EroscInput -> IO EroscOutput +processInput (EroscInput txt lists) = do + outLists <- mapM listPair lists + return $ EroscOutput outLists + where + listPair :: ErosList -> IO (ErosList, Score) + listPair ls = do + pmap <- loadPhraseMap ls + let scr = messageScore txt pmap + return (ls, scr) + + diff --git a/src/lib/Text/Eros/Message.hs b/src/lib/Text/Eros/Message.hs new file mode 100644 --- /dev/null +++ b/src/lib/Text/Eros/Message.hs @@ -0,0 +1,61 @@ +-- | +-- Module : Text.Eros.Message +-- Description : Module for censoring pieces of text. +-- Copyright : 2014, Peter Harpending +-- License : BSD3 +-- Maintainer : Peter Harpending +-- Stability : experimental +-- Portability : archlinux + +-- This module deals specifically with pieces of 'Text'. + +module Text.Eros.Message (messageScore) where + +-- Here, we have all the imports. +import Data.List +import qualified Data.Map.Strict as M +import qualified Data.Text.Lazy as L +import Data.Tree +import Text.Eros.Phrase +import Text.Eros.Phraselist + + +-- |I can never remember what I named things, so here are a bunch of +-- type synonyms. +type BadWord = L.Text +type Message = L.Text +type MessagePart = L.Text +type Restof = L.Text +type RestOf = L.Text +type Word = L.Text +type Score = Int + +-- |Does a top-level split of a 'Message'. Returns a list of pairs, +-- with the first element being the score up to that point in the +-- message, as well as the rest of the message. That gives you +-- somewhat of an idea how it works, but that's not quite it +messageSplit :: Message -> PhraseMap -> [(Score, RestOf)] +messageSplit initialText sayingsMap = concat $ filter (/= []) + $ nub + $ map breakSaying potentialSayings + where + potentialSayings = M.keys sayingsMap + breakSaying saying = map (trimSaying saying . snd) $ broked saying + trimSaying saying txt = (sayScore saying, L.strip $ L.drop (L.length saying) txt) + sayScore saying = case maybeScore saying of + Just score -> score + Nothing -> 0 + maybeScore saying = fmap score $ fmap rootLabel $ M.lookup saying sayingsMap + broked saying = L.breakOnAll saying lowerText -- looks like [("go ", "fuck yourself ")] + lowerText = L.toLower initialText -- looks like "go fuck yourself" (compared to "gO fUcK yOURSelf") + trimPair (a, b) = (L.strip a, L.strip b) -- looks like ("go", "fuck yourself") + +-- |Given a message, find its score. +messageScore :: Message -> PhraseMap -> Score +messageScore msg pmap + | L.empty == msg = 0 + | otherwise = (sum topScores) + (sum lowerScores) + where + msgSplit = messageSplit msg pmap + topScores = map fst msgSplit + lowerScores = map (\m -> messageScore m pmap) $ map snd msgSplit diff --git a/src/lib/Text/Eros/Phrase.hs b/src/lib/Text/Eros/Phrase.hs new file mode 100644 --- /dev/null +++ b/src/lib/Text/Eros/Phrase.hs @@ -0,0 +1,57 @@ +-- | +-- Module : Text.Eros.Phrase +-- Description : Pure interface for 'Phrase's and 'PhraseTree's. +-- Copyright : 2014, Peter Harpending. +-- License : BSD3 +-- Maintainer : Peter Harpending +-- Stability : experimental +-- Portability : archlinux +-- + +module Text.Eros.Phrase where + +import qualified Data.Map as M +import Data.Ord (comparing) +import Data.Text.Lazy (Text) +import Data.Tree + +-- |A Phrase is a piece of Text, with an int representing its +-- weight. These are the used internally within 'eros', in +-- 'Tree's. +data Phrase = Phrase { phrase :: Text + , score :: Int + } + deriving (Read, Show) + +instance Eq Phrase where + a == b = (score a) == (score b) + a /= b = (score a) /= (score b) + +instance Ord Phrase where + -- |To compare 'Phrases', just compare their 'score's + compare = comparing score + +-- |A 'Tree' of 'Phrase's +type PhraseTree = Tree Phrase +-- |A 'Forest' of 'Phrase's +type PhraseForest = Forest Phrase +-- |A Map of text values the appropriate tree +type PhraseMap = M.Map Text PhraseTree + +-- |The 'score' of the 'PhraseTree' is the sum of the 'score's of its 'Node's. +treeScore :: PhraseTree -> Int +treeScore = sum . map score . flatten + +-- |Given a list of 'PhraseTree's, return the top-level 'phrase's. +forestPhrases :: [PhraseTree] -> [Text] +forestPhrases = map forestPhrase + +-- |Given a 'PhraseTree', return the top-level 'phrase'. +forestPhrase :: PhraseTree -> Text +forestPhrase (Node phr subf) = phrase phr + +-- |Given a list of 'PhraseTree's, return a map of each phrase with +-- the appropriate tree. +mkMap :: PhraseForest -> PhraseMap +mkMap = M.fromList . phraseTreeAlist + where phraseTreeAlist frs = zip (forestPhrases frs) frs diff --git a/src/lib/Text/Eros/Phraselist.hs b/src/lib/Text/Eros/Phraselist.hs new file mode 100644 --- /dev/null +++ b/src/lib/Text/Eros/Phraselist.hs @@ -0,0 +1,330 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Text.Eros.Phraselist +-- Description : A module for dealing with Phraselists. +-- Copyright : 2014, Peter Harpending. +-- License : BSD3 +-- Maintainer : Peter Harpending +-- Stability : experimental +-- Portability : archlinux +-- +-- If you want to make your own phraselist, you need to write a JSON +-- file, in accordance with the +-- . +-- Once you do that, make a data type for your phraselist. +-- Make your data type an instance of 'Phraselist', and you're good to +-- go. +-- +-- For example, let's say your phraselist is @mylist.json@, and it's +-- all in accordance with the schema. Your code would look something +-- like this: +-- +-- @ +-- data MyList = MyList +-- +-- instance Phraselist MyList where +-- phraselistPath MyList = getDataFileName "mylist.json" +-- phraselistPath _ = undefined +-- @ +-- +-- Don't forget to add @mylist.json@ to @Data-Files@ in your @.cabal@ +-- file. +-- +-- If you want to use one of the lists we already supply +-- + +module Text.Eros.Phraselist where + +import Control.Applicative ((<$>), (<*>)) +import Control.Monad (mzero, sequence) +import Data.Aeson +import qualified Data.ByteString.Lazy as B +import qualified Data.Map as M +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as L +import Data.Tree +import Paths_eros +import System.Exit +import Text.Eros.Phrase + +class Phraselist t where + phraselistPath :: t -> IO FilePath + +-- |A set of 'Phraselist's. Note that this is actually a list, and I'm +-- calling it a "set" for purely lexical purposes. +type PhraselistSet = Phraselist t => [t] + +-- |The phraselists in @res/@. Each of these constructors correspond +-- to one of the files +-- . +-- +-- Gitlab has a terrible interface, so I won't provide links to each +-- one of them. +data ErosList = Chat + | Conspiracy + | DrugAdvocacy + | Forums + | Gambling + | Games + | Gore + | IdTheft + | IllegalDrugs + | Intolerance + | LegalDrugs + | Malware + | Music + | News + | Nudism + | Peer2Peer + | Personals + | Pornography + | Proxies + | SecretSocieties + | SelfLabeling + | Sport + | Translation + | UpstreamFilter + | Violence + | WarezHacking + | Weapons + | Webmail + +instance Eq ErosList where + (==) Chat Chat = True + (==) Conspiracy Conspiracy = True + (==) DrugAdvocacy DrugAdvocacy = True + (==) Forums Forums = True + (==) Gambling Gambling = True + (==) Games Games = True + (==) Gore Gore = True + (==) IdTheft IdTheft = True + (==) IllegalDrugs IllegalDrugs = True + (==) Intolerance Intolerance = True + (==) LegalDrugs LegalDrugs = True + (==) Malware Malware = True + (==) Music Music = True + (==) News News = True + (==) Nudism Nudism = True + (==) Peer2Peer Peer2Peer = True + (==) Personals Personals = True + (==) Pornography Pornography = True + (==) Proxies Proxies = True + (==) SecretSocieties SecretSocieties = True + (==) SelfLabeling SelfLabeling = True + (==) Sport Sport = True + (==) Translation Translation = True + (==) UpstreamFilter UpstreamFilter = True + (==) Violence Violence = True + (==) WarezHacking WarezHacking = True + (==) Weapons Weapons = True + (==) Webmail Webmail = True + (==) Chat _ = False + (==) Conspiracy _ = False + (==) DrugAdvocacy _ = False + (==) Forums _ = False + (==) Gambling _ = False + (==) Games _ = False + (==) Gore _ = False + (==) IdTheft _ = False + (==) IllegalDrugs _ = False + (==) Intolerance _ = False + (==) LegalDrugs _ = False + (==) Malware _ = False + (==) Music _ = False + (==) News _ = False + (==) Nudism _ = False + (==) Peer2Peer _ = False + (==) Personals _ = False + (==) Pornography _ = False + (==) Proxies _ = False + (==) SecretSocieties _ = False + (==) SelfLabeling _ = False + (==) Sport _ = False + (==) Translation _ = False + (==) UpstreamFilter _ = False + (==) Violence _ = False + (==) WarezHacking _ = False + (==) Weapons _ = False + (==) Webmail _ = False + +-- |A list of phraselists we provide. +erosLists :: [ErosList] +erosLists = [ Chat + , Conspiracy + , DrugAdvocacy + , Forums + , Gambling + , Games + , Gore + , IdTheft + , IllegalDrugs + , Intolerance + , LegalDrugs + , Malware + , Music + , News + , Nudism + , Peer2Peer + , Personals + , Pornography + , Proxies + , SecretSocieties + , SelfLabeling + , Sport + , Translation + , UpstreamFilter + , Violence + , WarezHacking + , Weapons + , Webmail + ] + +-- |A list of the paths to the phraselists we provide. +erosListPaths :: IO [FilePath] +erosListPaths = mapM phraselistPath erosLists + +erosListNames :: [L.Text] +erosListNames = [ "chat" + , "conspiracy" + , "drug-advocacy" + , "forums" + , "gambling" + , "games" + , "gore" + , "id-theft" + , "illegal-drugs" + , "intolerance" + , "legal-drugs" + , "malware" + , "music" + , "news" + , "nudism" + , "peer2peer" + , "personals" + , "pornography" + , "proxies" + , "secret-societies" + , "self-labeling" + , "sport" + , "translation" + , "upstream-filter" + , "violence" + , "warez-hacking" + , "weapons" + , "webmail" + ] + +-- |You can't really order the lists, so we won't use 'M.Map' +erosListNamePairs :: [(ErosList, L.Text)] +erosListNamePairs = zip erosLists erosListNames + +erosNameByList :: ErosList -> Maybe L.Text +erosNameByList key = lookup key erosListNamePairs + +erosNameListMap :: M.Map L.Text ErosList +erosNameListMap = M.fromList $ zip erosListNames erosLists + +erosListByName :: L.Text -> Maybe ErosList +erosListByName key = M.lookup key erosNameListMap + +-- These are the data paths for the various PhraseLists +instance Phraselist ErosList where + phraselistPath Chat = getDataFileName "res/phraselists-ugly/chat.json" + phraselistPath Conspiracy = getDataFileName "res/phraselists-ugly/conspiracy.json" + phraselistPath DrugAdvocacy = getDataFileName "res/phraselists-ugly/drug-advocacy.json" + phraselistPath Forums = getDataFileName "res/phraselists-ugly/forums.json" + phraselistPath Gambling = getDataFileName "res/phraselists-ugly/gambling.json" + phraselistPath Games = getDataFileName "res/phraselists-ugly/games.json" + phraselistPath Gore = getDataFileName "res/phraselists-ugly/gore.json" + phraselistPath IdTheft = getDataFileName "res/phraselists-ugly/id-theft.json" + phraselistPath IllegalDrugs = getDataFileName "res/phraselists-ugly/illegal-drugs.json" + phraselistPath Intolerance = getDataFileName "res/phraselists-ugly/intolerance.json" + phraselistPath LegalDrugs = getDataFileName "res/phraselists-ugly/legal-drugs.json" + phraselistPath Malware = getDataFileName "res/phraselists-ugly/malware.json" + phraselistPath Music = getDataFileName "res/phraselists-ugly/music.json" + phraselistPath News = getDataFileName "res/phraselists-ugly/news.json" + phraselistPath Nudism = getDataFileName "res/phraselists-ugly/nudism.json" + phraselistPath Peer2Peer = getDataFileName "res/phraselists-ugly/peer2peer.json" + phraselistPath Personals = getDataFileName "res/phraselists-ugly/personals.json" + phraselistPath Pornography = getDataFileName "res/phraselists-ugly/pornography.json" + phraselistPath Proxies = getDataFileName "res/phraselists-ugly/proxies.json" + phraselistPath SecretSocieties = getDataFileName "res/phraselists-ugly/secret-societies.json" + phraselistPath SelfLabeling = getDataFileName "res/phraselists-ugly/self-labeling.json" + phraselistPath Sport = getDataFileName "res/phraselists-ugly/sport.json" + phraselistPath Translation = getDataFileName "res/phraselists-ugly/translation.json" + phraselistPath UpstreamFilter = getDataFileName "res/phraselists-ugly/upstream-filter.json" + phraselistPath Violence = getDataFileName "res/phraselists-ugly/violence.json" + phraselistPath WarezHacking = getDataFileName "res/phraselists-ugly/warez-hacking.json" + phraselistPath Weapons = getDataFileName "res/phraselists-ugly/weapons.json" + phraselistPath Webmail = getDataFileName "res/phraselists-ugly/webmail.json" + +-- |Placeholder type used to read JSON. The JSON schema (currently, at +-- least) is such that one needs this type to read the JSON. You can +-- use 'fromPAT' to convert this type into a 'PhraseTree' +data PhraseAlmostTree = PhraseAlmostTree { patPhrase :: Text + , patScore :: Int + , patForest :: [PhraseAlmostTree] + } + deriving (Show, Read) + +-- |Alias for 'PhraseAlmostTree' +type PAT = PhraseAlmostTree + +-- |You can read the +-- +-- to see how this works. +instance FromJSON PAT where + parseJSON (Object v) = PhraseAlmostTree + <$> v .: "phrase" + <*> v .: "score" + <*> v .: "forest" + parseJSON _ = fail "Object not a PhraseAlmostTree." + +-- |Convert a 'PAT' into a 'PhraseTree'. +fromPAT :: PAT -> PhraseTree +fromPAT (PhraseAlmostTree p s f) = Node (Phrase p s) $ map fromPAT f + +-- |I figure some people like to type a lot. +fromPhraseAlmostTree :: PAT -> PhraseTree +fromPhraseAlmostTree = fromPAT + +-- |Read a 'Phraselist', marshal it into a 'PhraseForest'. +readPhraselist :: Phraselist t => t -> IO PhraseForest +readPhraselist elist = do + lpath <- phraselistPath elist + ltext <- B.readFile lpath + let ljson = (eitherDecode ltext) :: Either String [PAT] + case ljson of + Left msg -> fail msg + Right pats -> return $ map fromPAT pats + +-- |Alias for 'readPhraselist' +loadPhraselist :: Phraselist t => t -> IO PhraseForest +loadPhraselist = readPhraselist + +-- |Alias for 'readPhraselist' +readPhraseFile :: Phraselist t => t -> IO PhraseForest +readPhraseFile = readPhraselist + +-- |Alias for 'readPhraselist' +loadPhraseFile :: Phraselist t => t -> IO PhraseForest +loadPhraseFile = readPhraselist + +-- |Alias for 'readPhraselist' +readPhraseForest :: Phraselist t => t -> IO PhraseForest +readPhraseForest = readPhraselist + +-- |Alias for 'readPhraselist' +loadPhraseForest :: Phraselist t => t -> IO PhraseForest +loadPhraseForest = readPhraselist + +-- |Load a 'Phraselist' directly into a 'PhraseMap' +readPhraseMap :: Phraselist t => t -> IO PhraseMap +readPhraseMap plist = fmap mkMap $ readPhraselist plist + +-- |Alias for 'readPhraseMap' +loadPhraseMap :: Phraselist t => t -> IO PhraseMap +loadPhraseMap = readPhraseMap