Can parse the tags

This commit is contained in:
Mats Rauhala 2022-05-16 22:49:54 +03:00
parent c0dbc5f0d2
commit d253cbaa82
6 changed files with 80 additions and 6 deletions

View File

@ -1,5 +1,5 @@
{ mkDerivation, aeson, amqp, base, lens, lens-aeson, lib, mtl { mkDerivation, aeson, amqp, attoparsec, base, hspec, lens
, reddit-lib, text , lens-aeson, lib, mtl, reddit-lib, text, transformers
}: }:
mkDerivation { mkDerivation {
pname = "reddit-tags"; pname = "reddit-tags";
@ -8,10 +8,11 @@ mkDerivation {
isLibrary = true; isLibrary = true;
isExecutable = true; isExecutable = true;
libraryHaskellDepends = [ libraryHaskellDepends = [
aeson amqp base lens lens-aeson mtl reddit-lib text aeson amqp attoparsec base lens lens-aeson mtl reddit-lib text
transformers
]; ];
executableHaskellDepends = [ base ]; executableHaskellDepends = [ base ];
testHaskellDepends = [ base ]; testHaskellDepends = [ base hspec ];
license = "unknown"; license = "unknown";
hydraPlatforms = lib.platforms.none; hydraPlatforms = lib.platforms.none;
} }

View File

@ -20,6 +20,8 @@ extra-source-files: CHANGELOG.md
library library
exposed-modules: MyLib exposed-modules: MyLib
Tags
Transformer
-- Modules included in this library but not exported. -- Modules included in this library but not exported.
-- other-modules: -- other-modules:
@ -35,6 +37,8 @@ library
, lens , lens
, lens-aeson , lens-aeson
, transformers , transformers
, attoparsec
, bytestring
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
@ -59,3 +63,5 @@ test-suite reddit-tags-test
hs-source-dirs: test hs-source-dirs: test
main-is: MyLibTest.hs main-is: MyLibTest.hs
build-depends: base ^>=4.15.1.0 build-depends: base ^>=4.15.1.0
, hspec
, reddit-tags

View File

@ -10,6 +10,14 @@ import Control.Exception (bracket)
import Control.Concurrent (newEmptyMVar, readMVar) import Control.Concurrent (newEmptyMVar, readMVar)
import Control.Monad (void) import Control.Monad (void)
import Control.Lens
import Data.Aeson.Lens
import Transformer
import Data.ByteString.Lazy (ByteString)
import Control.Category ((>>>))
import Control.Arrow (arr, (&&&))
import Tags (parseTags)
data AMQP = AMQP data AMQP = AMQP
{ host :: String { host :: String
, vhost :: Text , vhost :: Text
@ -24,6 +32,12 @@ getAMQP = runMaybeT $
lookupEnvM = MaybeT . lookupEnv lookupEnvM = MaybeT . lookupEnv
lookupEnvMText = fmap T.pack . lookupEnvM lookupEnvMText = fmap T.pack . lookupEnvM
tagTransformer :: Transformer IO ByteString ()
tagTransformer =
arrOpt (preview (key "content" . key "title" . _String))
>>> arr id &&& arr parseTags
>>> liftTransformer print
someFunc :: IO () someFunc :: IO ()
someFunc = do someFunc = do
Just AMQP{..} <- getAMQP Just AMQP{..} <- getAMQP
@ -34,6 +48,10 @@ someFunc = do
declareQueue chan newQueue {queueName="reddit_tags"} declareQueue chan newQueue {queueName="reddit_tags"}
bindQueue chan "reddit_tags" "reddit_posts" "key" bindQueue chan "reddit_tags" "reddit_posts" "key"
consumeMsgs chan "reddit_tags" Ack $ \(msg, env) -> do consumeMsgs chan "reddit_tags" Ack $ \(msg, env) -> do
print msg void $ runTransformer tagTransformer (msgBody msg)
-- let body = msgBody msg
-- let title = body ^? key "content" . key "title"
-- print title
-- print $ parseTags title
ackEnv env ackEnv env
void getLine void getLine

18
reddit_tags/src/Tags.hs Normal file
View File

@ -0,0 +1,18 @@
{-# LANGUAGE ApplicativeDo #-}
module Tags (parseTags) where
import qualified Data.Attoparsec.Text as A
import Data.Attoparsec.Text (Parser)
import Data.Text (Text)
import Data.Either (fromRight)
tag :: Parser Text
tag = do
A.skipWhile (/= '[')
A.char '[' *> A.takeWhile (/= ']') <* A.char ']'
tags :: Parser [Text]
tags = A.many1 tag
parseTags :: Text -> [Text]
parseTags = fromRight [] . A.parseOnly tags

View File

@ -0,0 +1,18 @@
{-# LANGUAGE DerivingVia #-}
module Transformer where
import Control.Category ( Category )
import Control.Arrow ( Arrow, ArrowChoice, Kleisli(Kleisli) )
import Control.Monad.Trans.Maybe ( MaybeT(MaybeT) )
newtype Transformer m a b = Transformer (a -> m (Maybe b))
deriving (Category, Arrow, ArrowChoice) via Kleisli (MaybeT m)
arrOpt :: Applicative m => (a -> Maybe b) -> Transformer m a b
arrOpt f = Transformer (pure . f)
liftTransformer :: Monad m => (a -> m b) -> Transformer m a b
liftTransformer f = Transformer (fmap Just . f)
runTransformer :: Monad m => Transformer m a b -> a -> m (Maybe b)
runTransformer (Transformer tr) = tr

View File

@ -1,4 +1,17 @@
{-# LANGUAGE OverloadedStrings #-}
module Main (main) where module Main (main) where
import Tags (parseTags)
import Test.Hspec
main :: IO () main :: IO ()
main = putStrLn "Test suite not yet implemented." main = hspec $
describe "Parser" $ do
it "Returns no results if there are no tags" $
parseTags "foo bar" `shouldBe` []
it "Returns a single result" $
parseTags "[foo]" `shouldBe` ["foo"]
it "Finds multiple results" $
parseTags "[foo][bar]" `shouldBe` ["foo", "bar"]
it "Finds multiple results with other text interleaved" $
parseTags "prefix [foo] infix [bar] suffix" `shouldBe` ["foo", "bar"]