diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -12,148 +12,36 @@ Eros is still in development, and is not ready to be actually used. If you would like to contribute, please do. -At the time of this writing, I'm at version 0.3 (see -[here](https://github.com/pharpend/eros/releases)) for the current release. - -See the [API documentation on Hackage](http://hackage.haskell.org/package/eros) -if you want to learn how to use the library. +You can try the +[API documentation on Hackage](http://hackage.haskell.org/package/eros) if you +want to learn how to use the library. Hackage isn't terribly reliable at +successfully building the documentation, so I also publish the documentation on +[GitHub pages](https://pharpend.github.io/eros-haddock) -# Usage - v.0.3.1.0 +# Usage - v.0.4.0.0 This is a usage guide for version 0.3.1.0. There will be more up-to-date usage guides as more versions come, hopefully. -To install, run `cabal install eros`. - -## `erosc` - -The only way to interact with the library, for the time being is through the -client I built, `erosc`. It accepts input in Javascript Object Notation (JSON) -through `stdin`. - -Here is the schema for the input: - -```json -{ - "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" - } - }, - } -} -``` - -That is the up-to-date schema, as of version 0.3.1.0 . It is liable to -change. If the version you downloaded is greater than 0.3.1.0, make sure to -check the schema (it is distributed with the package) to make sure it is up to -date. The schema is located in `res/schemata/erosc-input.json`. - -`erosc` will take that input, and send back output in JSON, in accordance with -the schema found in `res/schemata/erosc-output.json`. - -```json -{ - "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." - } - } - } -} -``` - -## Example - -This is the example input from `res/erosc-dummy-inputs/input0.json`. - -```json -{ - "text": "Fuck you, you fucking fuck! Fucking bitch tits milf sex sluts!", - "eros-lists": [ - "gambling", - "pornography" - ] -} -``` - -Running `erosc < res/erosc-dummy-inputs/input0.json` yields - -```json -[ - { - "score": 0, - "eros-list": "gambling" - }, - { - "score": 11394, - "eros-list": "pornography" - } -] -``` - -## Library +To install, add `eros >=0.4 && <0.5` to the `build-depends` field in your +library's `.cabal` file -You are welcome to build your own client, and use that. To do so, simply import -`Text.Eros`. Hackage seems to be unable to build the API documentation for Eros, -but it won't hurt to check -[eros on Hackage](http://hackage.haskell.org/package/eros). +You can get all the functions, simply by `import`ing `Text.Eros`. -If that doesn't work, I publish the documentation +Hackage seems to be unable to build the API documentation for Eros, but it won't +hurt to check [eros on Hackage](http://hackage.haskell.org/package/eros). If +that doesn't work, I publish the documentation [here](https://pharpend.github.io/eros-haddock). # Contributing -If you want to contribute, you'll need `ghc` and `cabal-install` - -0. Clone the git repo - - git clone https://github.com/pharpend/eros.git - -1. Install in a sandbox - - cd eros - cabal sandbox init - cabal install --enable-tests - -# Planned features - -## `erosc` ⟶ `eros-server` - -As it stands, `erosc` is tedious and a bit difficult to use. I plan on rewriting -`erosc` to act as an HTTP[s] server, using Happstack, using acid-state as a RAM -cloud. This will be the fastest and easiest to maintain solution. - -I will still include an offline client, but it won't be the focus of -development. +I would love if people would contribute. QuickCheck tests are desperately +needed. -## More options +As far as functionality goes, this library is pretty cut & dry. I already added +all of the features I envisioned. -I need to add more filtering options, such as phraselist-specific thresholds, -custom phraselists, and, well, just more stuff. +# Contact -If you have any ideas, please don't hesitate to email me at -. +The best way to contact me is via IRC. I hang out on `#archlinux` and `#haskell` +on FreeNode. My handles are `l0cust` and `isomorpheous`. diff --git a/eros.cabal b/eros.cabal --- a/eros.cabal +++ b/eros.cabal @@ -1,5 +1,5 @@ name: eros -version: 0.3.1.0 +version: 0.4.0.0 synopsis: A text censorship library. description: A Haskell library for censoring text, using @@ -8,21 +8,10 @@ I converted the phraselists into JSON. You can view the converted phraselists . - There exist compressed versions, for use within your code. You can see the - compressed versions - . - - The library is not very well tested (or really, tested at all), so I wouldn't - recommend using it for anything important just quite yet. I'm quickly working - towards a stable version, though! - - I recommend looking at the API documentation for Text.Eros if you want an idea - of how to use the library. Hackage seems to be completely unable to build the - documentation for Eros. For that reason, I publish the documentation + I recommend looking at the API documentation for 'Text.Eros' if you want an + idea of how to use the library. I publish the documentation . - --- homepage: https://eros.valkyrian.com/ license: BSD3 license-file: LICENSE author: Peter Harpending @@ -36,7 +25,6 @@ cabal-version: >=1.10 extra-source-files: README.md - res/erosc-dummy-inputs/*.json res/schemata/*.json res/phraselists-pretty/*.json @@ -57,37 +45,8 @@ , bytestring , containers , text - hs-source-dirs: src/library/ - default-language: Haskell2010 - -Test-Suite test-eros - type: exitcode-stdio-1.0 - hs-source-dirs: test/ - main-is: Main.hs - other-modules: - TextErosPhrase - build-depends: - base - , containers - , eros - , QuickCheck - , text + hs-source-dirs: src/ default-language: Haskell2010 - -executable erosc - build-depends: - aeson - , aeson-pretty - , base >=4.7 && <4.8 - , bytestring - , containers - , eros - , text - hs-source-dirs: src/client/ - main-is: Main.lhs - other-modules: Erosc.Processor - default-language: Haskell2010 - ghc-options: -Wall source-repository head type: git diff --git a/res/erosc-dummy-inputs/input0.json b/res/erosc-dummy-inputs/input0.json deleted file mode 100644 --- a/res/erosc-dummy-inputs/input0.json +++ /dev/null @@ -1,7 +0,0 @@ -{ - "text": "Fuck you, you fucking fuck! Fucking bitch tits milf sex sluts!", - "eros-lists": [ - "gambling", - "pornography" - ] -} diff --git a/res/schemata/erosc-input.json b/res/schemata/erosc-input.json deleted file mode 100644 --- a/res/schemata/erosc-input.json +++ /dev/null @@ -1,20 +0,0 @@ -{ - "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 deleted file mode 100644 --- a/res/schemata/erosc-output.json +++ /dev/null @@ -1,19 +0,0 @@ -{ - "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/src/Text/Eros.lhs b/src/Text/Eros.lhs new file mode 100644 --- /dev/null +++ b/src/Text/Eros.lhs @@ -0,0 +1,22 @@ +| +Module : Text.Eros +Description : Capstone Module for eros +Copyright : 2014, Peter Harpending. +License : BSD3 +Maintainer : Peter Harpending +Stability : experimental +Portability : archlinux + +This module serves as a bit of a capstone to the whole eros +library. The idea being you can just import this module, and get +all of the functions from all the rest of eros. + +You will have to look in the documentation for the sub-modules for +the functions. I haven't quite figured out how to get the +documentation to show up here yet. + +> module Text.Eros (module Text.Eros) where + +> import Text.Eros.Message as Text.Eros +> import Text.Eros.Phrase as Text.Eros +> import Text.Eros.Phraselist as Text.Eros diff --git a/src/Text/Eros/Message.hs b/src/Text/Eros/Message.hs new file mode 100644 --- /dev/null +++ b/src/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/Text/Eros/Phrase.hs b/src/Text/Eros/Phrase.hs new file mode 100644 --- /dev/null +++ b/src/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/Text/Eros/Phraselist.hs b/src/Text/Eros/Phraselist.hs new file mode 100644 --- /dev/null +++ b/src/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 diff --git a/src/client/Erosc/Processor.hs b/src/client/Erosc/Processor.hs deleted file mode 100644 --- a/src/client/Erosc/Processor.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} - --- |This is the module which actually processes the marshals the --- data. As far as erosc goes, this is the meat & potatoes. --- --- Basically, Main.hs was getting to be too long, so I created this --- file. --- --- Copyright (c) 2014, Peter Harpending . All --- Rights Reserved. --- --- I'm supposed to say "All Rights Reserved," but this is actuallly --- BSD-licensed. So, really you can do whatever you want with --- this. Have fun! - -module Erosc.Processor where - --- One of these days, I'm going to figure out how to cut down on these --- imports. -import Control.Applicative -import Control.Monad (mzero) -import Data.Aeson hiding (encode) -import Data.Aeson.Encode.Pretty -import qualified Data.ByteString.Lazy as LzByte -import qualified Data.Text.Lazy as LzText -import Text.Eros - --- |Okay, here's a function that actually does something. It takes an --- 'Input' type, and process it. -processInput :: Input -> IO Output -processInput (Input txt lists) = do - outLists <- mapM listPair lists - return $ Output outLists - where - listPair :: ErosList -> IO (ErosList, Score) - listPair ls = do - pmap <- loadPhraseMap ls - let scr = messageScore txt pmap - return (ls, scr) - --- |This will print JSON in a pretty matter, using 2-space indents. I --- have no idea why 4-space indents are the default. -encode :: ToJSON a => a -> LzByte.ByteString -encode = encodePretty' defConfig { confIndent = 2 - } - --- |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 Input = Input { 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 Input where - parseJSON (Object v) = Input - <$> 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 Output = Output { elScore :: [(ErosList, Score)] } - --- |Pretty self-explanatory -instance ToJSON ErosList where - toJSON el = case erosNameByList el of - Just nom -> toJSON nom - Nothing -> "There's probably a bug in the JSON parsing \ - \library Eros uses. You should file a bug \ - \report at https://github.com/pharpend/eros/issues." - --- |Pretty self-explanatory -instance ToJSON (ErosList, Score) where - toJSON (el, sc) = object [ "eros-list" .= el - , "score" .= sc - ] - --- |Pretty self-explanatory -instance ToJSON Output where - toJSON (Output elm) = toJSON elm - --- |It's convenient to think of Scores as Scores, although, they are --- truly ints. -type Score = Int diff --git a/src/client/Main.lhs b/src/client/Main.lhs deleted file mode 100644 --- a/src/client/Main.lhs +++ /dev/null @@ -1,78 +0,0 @@ -|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 - - -So, here are our imports. I would like to only have IO inputs, however -the import of 'Data.Aeson' is needed in order to keep the -'Erosc.Processor' module pure. - -Essentially, I was faced with either making this module be tainted by -purity, or have the other module be pure. - -My qualified imports are a bit obnoxious. Even though they aren't -needed, I find that using qualified names makes the code a bit less -confusing. That is, @LzByte.hGetContents@ is a lot more informative -than just @hGetContents@. - -> import Data.Aeson as Aeson -> import qualified Data.ByteString.Lazy as LzByte -> import Erosc.Processor as Erosc -> import qualified System.IO as StdIO - - -|Eventually, I'll need this data type when I use command line -arguments. For the moment, it's just a dummy type. So, enjoy it. - -> data EroscOpts = EroscOpts - -|So, this is the main function. Whoop de doo. It sends the contents -of 'StdIO.stdin' to runBtStr. - -Eventually, I'll add in command line argument parsing, and then we'll -have a use for the 'EroscOptions' type. - -> main :: IO () -> main = runBtStr =<< LzByte.hGetContents StdIO.stdin - -|This function takes the input (presumably 'StdIO.stdin'), and tries -to decode it. - -If it successfully decodes the input into the 'Erosc.Input' type, -it sends the newfound decoded input to 'runInput', which sends it to -the processor. - -If it can't, the program will throw a tantrum and shit itself. - -> runBtStr :: LzByte.ByteString -> IO () -> runBtStr inputBt = do -> let eitherJson = (Aeson.eitherDecode inputBt) :: Either String Erosc.Input -> case eitherJson of -> Left msg -> fail msg -> Right ecInput -> runInput ecInput - - -There is an astonishing quantity of bureaucracy in this program. You -have to go through like 5 functions before you get to a function that -actually does something useful. - -|Okay, so, we're getting closer to the part of the program that -actually does stuff (or further away, depending on the location from -whence you come). - -'runInput' takes the 'Erosc.Input' object (I do hate that word), and -sends it to some function in 'Erosc' that actually mutates the -data. Well, it doesn't mutate it, obviously, because this is Haskell, -but you get the idea. - -@result@ needs to be '(<-)'d because 'Erosc.processInput' needs to -read the phraselist JSON file. This is a result of poor library design -on my part. I will fix this in a future release. - -> runInput :: Erosc.Input -> IO () -> runInput ipt = do -> result <- Erosc.processInput ipt -> let jsonText = Erosc.encode result -> LzByte.hPutStr StdIO.stdout jsonText - diff --git a/src/library/Text/Eros.lhs b/src/library/Text/Eros.lhs deleted file mode 100644 --- a/src/library/Text/Eros.lhs +++ /dev/null @@ -1,22 +0,0 @@ -| -Module : Text.Eros -Description : Capstone Module for eros -Copyright : 2014, Peter Harpending. -License : BSD3 -Maintainer : Peter Harpending -Stability : experimental -Portability : archlinux - -This module serves as a bit of a capstone to the whole eros -library. The idea being you can just import this module, and get -all of the functions from all the rest of eros. - -You will have to look in the documentation for the sub-modules for -the functions. I haven't quite figured out how to get the -documentation to show up here yet. - -> module Text.Eros (module Text.Eros) where - -> import Text.Eros.Message as Text.Eros -> import Text.Eros.Phrase as Text.Eros -> import Text.Eros.Phraselist as Text.Eros diff --git a/src/library/Text/Eros/Message.hs b/src/library/Text/Eros/Message.hs deleted file mode 100644 --- a/src/library/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/library/Text/Eros/Phrase.hs b/src/library/Text/Eros/Phrase.hs deleted file mode 100644 --- a/src/library/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/library/Text/Eros/Phraselist.hs b/src/library/Text/Eros/Phraselist.hs deleted file mode 100644 --- a/src/library/Text/Eros/Phraselist.hs +++ /dev/null @@ -1,330 +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 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 diff --git a/test/Main.hs b/test/Main.hs deleted file mode 100644 --- a/test/Main.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Main where - -import Control.Applicative -import qualified Data.Text.Lazy as T -import Test.QuickCheck -import TextErosPhrase - -instance Arbitrary T.Text where - arbitrary = T.pack <$> arbitrary - shrink xs = T.pack <$> shrink (T.unpack xs) - -main :: IO () -main = do - quickCheck ordPhraseForest diff --git a/test/TextErosPhrase.hs b/test/TextErosPhrase.hs deleted file mode 100644 --- a/test/TextErosPhrase.hs +++ /dev/null @@ -1,22 +0,0 @@ --- |Some tests for the Text.Eros.Phrase module -module TextErosPhrase where - -import Data.List -import qualified Data.Map.Strict as M -import qualified Data.Text.Lazy as T -import Data.Tree -import Test.QuickCheck -import Text.Eros.Phrase - --- |Given Text Int pairs, make some phrases -mkPhrases :: [(T.Text, Int)] -> [Phrase] -mkPhrases [] = [] -mkPhrases ((s, i):x) = psi:px - where psi = Phrase s i - px = mkPhrases x - --- |Try to order the phrases -ordPhraseForest :: [(T.Text, Int)] -> Bool -ordPhraseForest ti = phraseOrd == scoreOrd - where scoreOrd = sort $ map snd ti - phraseOrd = map score $ sort $ mkPhrases ti