concrete-haskell 0.1.0.14 → 0.1.0.15
raw patch · 18 files changed
+432/−272 lines, 18 filesdep +stm
Dependencies added: stm
Files
- concrete-haskell.cabal +13/−77
- src/Data/Concrete.hs +6/−0
- src/Data/Concrete/Parsers.hs +26/−37
- src/Data/Concrete/Parsers/CONLL.hs +28/−11
- src/Data/Concrete/Parsers/CSV.hs +4/−4
- src/Data/Concrete/Parsers/JSON.hs +2/−1
- src/Data/Concrete/Parsers/PTB.hs +11/−9
- src/Data/Concrete/Parsers/Types.hs +5/−1
- src/Data/Concrete/Parsers/Utils.hs +79/−22
- src/Data/Concrete/Services.hs +10/−2
- src/Data/Concrete/Services/Fetch.hs +55/−12
- src/Data/Concrete/Services/Store.hs +40/−26
- src/Data/Concrete/Utils.hs +43/−19
- tests/TestIngesters.hs +73/−6
- tests/TestSerialization.hs +0/−22
- utils/FetchService.hs +11/−5
- utils/InspectCommunications.hs +18/−15
- utils/StoreService.hs +8/−3
concrete-haskell.cabal view
@@ -3,9 +3,9 @@ -- see: https://github.com/sol/hpack name: concrete-haskell-version: 0.1.0.14+version: 0.1.0.15 synopsis: Library for the Concrete data format.-description: Concrete is a Thrift-based data specification designed for Natural Language Processing (NLP) applications. This library provides a Haskell interface to code generated from the latest release of Concrete. It also has a number of utilities for converting various formats (JSON, CSV, XML, etc) to Concrete Communication objects.+description: Concrete is a Thrift-based data specification designed for Natural Language Processing (NLP) applications. This library provides a Haskell interface to code generated from the latest release of Concrete (the concrete-haskell-autogen package). It also has an ingest utility for converting various formats (JSON, CSV, XML, etc) to Concrete Communication objects. category: Data homepage: https://github.com/hltcoe author: Thomas Lippincott@@ -40,6 +40,7 @@ , path-io ==1.2.2 , process ==1.4.3.0 , scientific ==0.3.5.1+ , stm ==2.4.4.1 , tar ==0.5.0.3 , text ==1.2.2.2 , thrift ==0.10.0@@ -50,7 +51,6 @@ , zip ==0.1.11 , zlib ==0.6.1.2 exposed-modules:- Data.Concrete Data.Concrete.Utils Data.Concrete.Services Data.Concrete.Services.Fetch@@ -60,13 +60,14 @@ Data.Concrete.Parsers.Utils Data.Concrete.Parsers.JSON Data.Concrete.Parsers.CONLL- Data.Concrete.Parsers.Email- Data.Concrete.Parsers.XML Data.Concrete.Parsers.CSV- Data.Concrete.Parsers.HTML Data.Concrete.Parsers.PTB- Data.Concrete.Parsers.RFC2822 other-modules:+ Data.Concrete+ Data.Concrete.Parsers.Email+ Data.Concrete.Parsers.HTML+ Data.Concrete.Parsers.RFC2822+ Data.Concrete.Parsers.XML Paths_concrete_haskell default-language: Haskell2010 @@ -94,6 +95,7 @@ , path-io ==1.2.2 , process ==1.4.3.0 , scientific ==0.3.5.1+ , stm ==2.4.4.1 , tar ==0.5.0.3 , text ==1.2.2.2 , thrift ==0.10.0@@ -130,6 +132,7 @@ , path-io ==1.2.2 , process ==1.4.3.0 , scientific ==0.3.5.1+ , stm ==2.4.4.1 , tar ==0.5.0.3 , text ==1.2.2.2 , thrift ==0.10.0@@ -167,6 +170,7 @@ , path-io ==1.2.2 , process ==1.4.3.0 , scientific ==0.3.5.1+ , stm ==2.4.4.1 , tar ==0.5.0.3 , text ==1.2.2.2 , thrift ==0.10.0@@ -203,6 +207,7 @@ , path-io ==1.2.2 , process ==1.4.3.0 , scientific ==0.3.5.1+ , stm ==2.4.4.1 , tar ==0.5.0.3 , text ==1.2.2.2 , thrift ==0.10.0@@ -238,76 +243,7 @@ , path-io ==1.2.2 , process ==1.4.3.0 , scientific ==0.3.5.1- , tar ==0.5.0.3- , text ==1.2.2.2- , thrift ==0.10.0- , time ==1.6.0.1- , unordered-containers ==0.2.8.0- , uuid ==1.3.13- , vector ==0.10.12.2- , zip ==0.1.11- , zlib ==0.6.1.2- , concrete-haskell- default-language: Haskell2010--test-suite serialization- type: exitcode-stdio-1.0- main-is: tests/TestSerialization.hs- build-depends:- QuickCheck ==2.9.2- , base >=4.6 && <5- , binary ==0.8.3.0- , bytestring ==0.10.8.1- , bzlib ==0.5.0.5- , concrete-haskell-autogen ==0.0.0.1- , containers ==0.5.7.1- , directory ==1.3.0.0- , filepath ==1.4.1.1- , hashable ==1.2.6.1- , megaparsec ==5.3.1- , monad-extras ==0.6.0- , mtl ==2.2.1- , network ==2.6.3.2- , optparse-generic ==1.2.2- , path ==0.5.13- , path-io ==1.2.2- , process ==1.4.3.0- , scientific ==0.3.5.1- , tar ==0.5.0.3- , text ==1.2.2.2- , thrift ==0.10.0- , time ==1.6.0.1- , unordered-containers ==0.2.8.0- , uuid ==1.3.13- , vector ==0.10.12.2- , zip ==0.1.11- , zlib ==0.6.1.2- , concrete-haskell- default-language: Haskell2010--benchmark ingest- type: exitcode-stdio-1.0- main-is: tests/TestIngesters.hs- build-depends:- QuickCheck ==2.9.2- , base >=4.6 && <5- , binary ==0.8.3.0- , bytestring ==0.10.8.1- , bzlib ==0.5.0.5- , concrete-haskell-autogen ==0.0.0.1- , containers ==0.5.7.1- , directory ==1.3.0.0- , filepath ==1.4.1.1- , hashable ==1.2.6.1- , megaparsec ==5.3.1- , monad-extras ==0.6.0- , mtl ==2.2.1- , network ==2.6.3.2- , optparse-generic ==1.2.2- , path ==0.5.13- , path-io ==1.2.2- , process ==1.4.3.0- , scientific ==0.3.5.1+ , stm ==2.4.4.1 , tar ==0.5.0.3 , text ==1.2.2.2 , thrift ==0.10.0
src/Data/Concrete.hs view
@@ -1,2 +1,8 @@+{-|+Description: test++tests+-}+ module Data.Concrete ( ) where
src/Data/Concrete/Parsers.hs view
@@ -1,12 +1,14 @@ {-# LANGUAGE DeriveGeneric, OverloadedStrings #-} {-|+Description : Parsers and utilities for ingesting various formats to Concrete+ This module is designed to enable converting arbitrary formats described as simple context-free (or even context-sensitive) grammars into Concrete Communication objects. -UUIDs are generated when the Communications are serialized,-and so the module avoids the need for any impure computations-until that point.+A base UUID is generated randomly for each Communication, and subsequent UUIDs+within the Communication are increments of the base: this allows for more+efficient compression. -} module Data.Concrete.Parsers ( communicationParsers@@ -17,25 +19,11 @@ import Data.Vector (fromList, Vector) import Data.Map (Map) import Data.Concrete.Utils (createAnnotationMetadata, getUUID, writeCommunication)--- import Data.Concrete ( default_Communication--- , Communication(..)--- , default_Section--- , Section(..)--- , default_AnnotationMetadata--- , AnnotationMetadata(..)--- , default_CommunicationMetadata--- , CommunicationMetadata(..)--- , default_Sentence--- , Sentence(..)--- , default_TextSpan--- , TextSpan(..)--- ) import System.IO (stdin, stdout, stderr, openFile, Handle, IOMode(..), hPutStrLn) import Control.Monad.State (runStateT) import Data.ByteString.Lazy (ByteString) import Data.Text.Lazy (Text, pack) import Data.Concrete.Autogen.Communication_Types (default_Communication, Communication(..))---import Data.Concrete.Types import Data.Concrete.Parsers.Types import Control.Monad.IO.Class (liftIO) import Text.Megaparsec (runParserT', initialPos, State(..), unsafePos, parseErrorPretty, eof, space)@@ -49,14 +37,14 @@ import qualified Data.Concrete.Parsers.Email as Email import qualified Data.Concrete.Parsers.PTB as PTB -+-- | List of ingest configurations and default parameters communicationParsers = [( "JSON" , ( "JSON array of arbitrary objects" , JSON.parser , [ "catchphrase" , "relatives.0.name" ]- , "id_${name}"+ , "json_${name}" ) ) , ( "JSON-LINES"@@ -65,33 +53,33 @@ , [ "author" , "subreddit" ]- , "id_${name}"+ , "json-lines_${name}" ) ) , ( "CSV" , ( "CSV format (with header, commas)"- , CSV.parser True ','+ , CSV.parser Nothing ',' , [ "technology" , "Bush" , "Gore" ]- , "id_${county}"+ , "csv_${county}" ) )- -- , ( "PTB"- -- , ( "PENN Treebank format"- -- , PTB.parser- -- , []- -- , "id_${}"- -- )- -- )- -- , ("CONLL-U"- -- , ( "CONLL-U format"- -- , CONLL.parser CONLL.ufields- -- , []- -- , "id_${}"- -- )- -- )+ , ("CONLL-U"+ , ( "CONLL-U format"+ , CONLL.parser CONLL.conllufields+ , ["sentence"]+ , "conll_${}"+ )+ )+ , ( "PTB"+ , ( "PENN Treebank format"+ , PTB.parser+ , ["sentence"]+ , "ptb_${}"+ )+ ) -- , ("HTML" -- , ("HTML format" -- , HTML.parser@@ -115,6 +103,7 @@ -- ) ] +-- | Run CommunicationAction on each entry created during the ingest process ingest :: CommunicationAction -> CommunicationParser a -> Text -> [String] -> String -> String -> IO () ingest a p t cs i ct = do let s = State { stateInput=t@@ -122,7 +111,7 @@ , stateTokensProcessed=0 , stateTabWidth=unsafePos 8 }- ((_, e), _) <- runStateT (runParserT' (space >> p >> space >> eof) s) (Bookkeeper (default_Communication { communication_sectionList=Just empty }) Map.empty [] [] a cs (pack i) ct 0)+ ((_, e), _) <- runStateT (runParserT' (space >> p >> space >> eof) s) (Bookkeeper (default_Communication { communication_sectionList=Just empty }) Map.empty [] [] [] [] a cs (pack i) ct 0 0) case e of Left x -> putStrLn $ parseErrorPretty x _ -> return ()
src/Data/Concrete/Parsers/CONLL.hs view
@@ -1,8 +1,10 @@ {-# LANGUAGE DeriveGeneric, OverloadedStrings, ApplicativeDo #-} module Data.Concrete.Parsers.CONLL ( parser- , xfields- , ufields+ , singleParser+ , conllxfields+ , conllufields+ , conll2009fields ) where import Data.List (intercalate)@@ -52,15 +54,32 @@ import qualified Control.Monad.State as S import qualified Control.Monad.Identity as I --import Data.Concrete.Types-import Data.Concrete.Parsers.Utils (communicationRule, sectionRule, pushPathComponent, popPathComponent)+import Data.Concrete.Parsers.Utils (communicationRule, sectionRule, sentenceRule, tokenRule, pushPathComponent, popPathComponent) -ufields = ["ID", "FORM", "LEMMA", "UPOSTAG", "XPOSTAG", "FEATS", "HEAD", "DEPREL", "DEPS", "MISC"] :: [Text]-xfields = ["ID", "FORM", "LEMMA", "PLEMMA", "POS", "PPOS", "FEAT", "PFEAT", "HEAD", "PHEAD", "DEPREL", "PDEPREL"] :: [Text]+-- | Field names for the CONLL-X format+conllxfields = ["ID", "FORM", "LEMMA", "PLEMMA", "POS", "PPOS", "FEAT", "PFEAT", "HEAD", "PHEAD"] :: [Text] +-- | Field names for the CONLL-U format+conllufields = ["ID", "FORM", "LEMMA", "UPOSTAG", "XPOSTAG", "FEATS", "HEAD", "DEPREL", "DEPS", "MISC"] :: [Text]++-- | Field names for the CONLL2009 format+conll2009fields = ["ID", "FORM", "LEMMA", "UPOSTAG", "XPOSTAG", "FEATS", "HEAD", "DEPREL", "DEPS", "MISC", "DEPREL", "PDEPREL", "FILLPRED", "PRED"] ++ (map (\x -> pack $ "APRED" ++ (show x)) [1..16]) :: [Text]++-- | Parses different flavors of CONLL depending on which fields are passed as arguments+-- Each sentence is made into its own Communication parser :: [Text] -> CommunicationParser () parser fs = (communicationRule id (sentence fs)) `sepBy1` sentenceBreak >> return () -sentence fs = (some (commentLine <|> wordLine fs)) >> return ()+-- | Parses different flavors of CONLL depending on which fields are passed as arguments+-- All input sentences are placed in a single Communication+singleParser :: [Text] -> CommunicationParser ()+singleParser fs = (communicationRule id (sentence fs)) `sepBy1` sentenceBreak >> return ()+ +sentence fs = do+ pushPathComponent "sentence"+ (sectionRule id . sentenceRule id) $ (some (commentLine <|> wordLine fs))+ popPathComponent+ return () commentLine = (char '#') >> (manyTill anyChar newline) @@ -72,10 +91,8 @@ newline return () -namedEntry f = do- pushPathComponent (unpack f)- t <- sectionRule id $ pack <$> (some (noneOf ['\t', '\n']))- popPathComponent- return t+-- | Parse a CONLL cell, which if it's "FORM" should be treated as a Token+namedEntry :: Text -> ParsecT Dec Text (S.StateT Bookkeeper IO) Text+namedEntry f = if f == "FORM" then tokenRule id $ pack <$> (some (noneOf ['\t', '\n'])) else pack <$> (some (noneOf ['\t', '\n'])) sentenceBreak = newline
src/Data/Concrete/Parsers/CSV.hs view
@@ -10,6 +10,7 @@ import Data.Text.Lazy (pack, unpack, Text) import qualified Data.Text.Lazy as T import Data.Functor (($>))+import Data.Maybe (fromJust) import qualified Data.Map as Map import Data.Map (Map) import Data.List.NonEmpty (fromList)@@ -44,15 +45,14 @@ ) import Data.Concrete.Autogen.Communication_Types (default_Communication, Communication(..)) import Text.Megaparsec.Text.Lazy (Parser)---import Data.Concrete (default_Communication, Communication(..)) import qualified Control.Monad.State as S import qualified Control.Monad.Identity as I---import Data.Concrete.Types import Data.Concrete.Parsers.Utils (communicationRule, sectionRule, pushPathComponent, popPathComponent) -parser :: Bool -> Char -> CommunicationParser ()+-- | Parser for CSV files+parser :: Maybe [Text] -> Char -> CommunicationParser () parser h d = do- fs <- if h == True then header d else return []+ fs <- if h == Nothing then header d else return $ fromJust h space withFields fs d space
src/Data/Concrete/Parsers/JSON.hs view
@@ -44,7 +44,6 @@ import qualified Control.Monad.State as S import qualified Control.Monad.Identity as I import Data.Concrete.Autogen.Communication_Types (default_Communication, Communication(..))---import Data.Concrete (default_Communication, Communication(..), Section(..), TextSpan(..)) import Data.Concrete.Parsers.Types (Bookkeeper(..), CommunicationParser) import Data.Concrete.Parsers.Utils ( communicationRule , sectionRule@@ -59,9 +58,11 @@ , incrementPathComponent ) +-- | Parses an array of JSON objects, turning each into a Communication parser :: CommunicationParser () parser = brackets ((communicationRule id objectP) `sepBy` comma) >> return () +-- | Parses a sequence of JSON objects (i.e. not a valid JSON object overall), like one object per line lineParser :: CommunicationParser () lineParser = (many (communicationRule id objectP)) >> return ()
src/Data/Concrete/Parsers/PTB.hs view
@@ -47,9 +47,10 @@ import Data.Concrete.Autogen.Communication_Types (default_Communication, Communication(..)) import qualified Control.Monad.State as S import qualified Control.Monad.Identity as I---import Data.Concrete.Types-import Data.Concrete.Parsers.Utils (communicationRule, sectionRule)+import Data.Concrete.Parsers.Utils (communicationRule, sectionRule, sentenceRule, tokenRule, pushPathComponent, popPathComponent) +-- | Parser for PENN Treebank format+-- NOTE: currently, doesn't capture tags/parses parser :: CommunicationParser () parser = do space@@ -58,18 +59,19 @@ eof return () --- type CS = CommunicationParser String--- type CSS = CommunicationParser [String]--- type CC = CommunicationParser Char- document :: CommunicationParser () document = lexeme' $ communicationRule id (parens (some sentence)) >> return () -sentence = lexeme' $ between (symbol' "(S") (symbol' ")") (some phrase)--phrase = lexeme' $ parens (tag >> some (tag <|> phrase)) >> return []+sentence = do+ pushPathComponent "sentence"+ (sectionRule id . sentenceRule id) $ lexeme' $ between (symbol' "(S") (symbol' ")") (some phrase)+ popPathComponent + +phrase = lexeme' $ parens (tag >> some (token <|> phrase)) >> return [] tag = lexicalItem++token = tokenRule id lexicalItem lexicalItem = lexeme' $ some notSpaceOrParen
src/Data/Concrete/Parsers/Types.hs view
@@ -8,11 +8,12 @@ import Data.Text.Lazy (Text) import Data.Concrete.Autogen.Communication_Types (Communication)-import Data.Concrete.Autogen.Structure_Types (Section, Sentence)+import Data.Concrete.Autogen.Structure_Types (Section, Sentence, Token) import Text.Megaparsec (ParsecT) import Text.Megaparsec.Error (Dec) import Data.Map (Map) import Control.Monad.State (StateT)+import GHC.Int -- | A 'CommunicationAction' gets called on each Communication -- as parsing proceeds@@ -57,11 +58,14 @@ , valueMap :: Map String String -- | An arbitrary string-to-string map , path :: [String] , sections :: [Section] -- | List of Sections accumulated for the Communication currently being parsed+ , sentences :: [Sentence] -- | List of Sections accumulated for the Communication currently being parsed+ , tokens :: [Token] -- | List of Sections accumulated for the Communication currently being parsed , action :: CommunicationAction , contentSections :: [String] , commId :: Text , commType :: String , commNum :: Int+ , offset :: GHC.Int.Int32 } -- | A StatefulParser is just a Megaparsec Parser that carries
src/Data/Concrete/Parsers/Utils.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE DeriveGeneric, OverloadedStrings #-} module Data.Concrete.Parsers.Utils ( communicationRule , sectionRule+ , sentenceRule+ , tokenRule , pathDictionaryRule , pathDictionaryKeyRule , pathArrayRule@@ -22,18 +24,84 @@ import qualified Data.Map as Map import Control.Monad.State (State, get, put, modify, modify') import Data.Concrete.Autogen.Communication_Types (Communication(..), default_Communication)-import Data.Concrete.Autogen.Structure_Types (Section(..), default_Section)-import Data.Concrete.Autogen.Spans_Types (TextSpan(..), default_TextSpan)+import Data.Concrete.Autogen.Structure_Types (Section(..), default_Section, Token(..), default_Token, Sentence(..), default_Sentence, TokenizationKind(..), Tokenization(..), default_Tokenization, TokenList(..), default_TokenList)+import Data.Concrete.Autogen.Spans_Types (TextSpan(..), default_TextSpan, AudioSpan(..), default_AudioSpan) import Data.Concrete.Utils (getUUID, createAnnotationMetadata, incrementUUID) import Control.Monad.IO.Class (liftIO) import Data.Vector (Vector, fromList, snoc, empty, cons, toList)+import qualified Data.Vector as V import Data.Maybe (fromJust) import Text.Printf (printf) --- | Wraps a rule that corresponds to a single Communication+-- | Wraps a rule corresponding to a Token+tokenRule :: (Token -> Token) -> CommunicationParser a -> CommunicationParser a+tokenRule t p = do+ s <- (fromIntegral . stateTokensProcessed) <$> getParserState+ v <- p+ e <- (fromIntegral . stateTokensProcessed) <$> getParserState+ bs@(Bookkeeper {..}) <- get+ let token = t $ default_Token { token_textSpan=Just $ TextSpan (s - offset) (e - offset)+ , token_tokenIndex=fromIntegral $ length tokens+ }+ put $ bs { tokens=token:tokens+ }+ return v+ +-- | Wraps a rule corresponding to a Sentence+sentenceRule :: (Sentence -> Sentence) -> CommunicationParser a -> CommunicationParser a+sentenceRule t p = do+ s <- (fromIntegral . stateTokensProcessed) <$> getParserState+ v <- p+ e <- (fromIntegral . stateTokensProcessed) <$> getParserState+ bs@(Bookkeeper {..}) <- get+ u <- liftIO getUUID+ m <- liftIO $ createAnnotationMetadata "concrete-haskell ingester"+ let tokenList = default_TokenList { tokenList_tokenList=V.fromList (reverse tokens)+ }+ tokenization = default_Tokenization { tokenization_tokenList=Just tokenList+ , tokenization_metadata=m+ , tokenization_uuid=u+ , tokenization_kind=TOKEN_LIST+ }+ sentence = t $ default_Sentence { sentence_textSpan=Just $ TextSpan (s - offset) (e - offset)+ , sentence_tokenization=Just tokenization+ }+ put $ bs { sentences=sentence:sentences+ , tokens=[]+ }+ return v+ +-- | Wraps a rule corresponding to a Section+sectionRule :: (Section -> Section) -> CommunicationParser a -> CommunicationParser a+sectionRule t p = do+ s <- (fromIntegral . stateTokensProcessed) <$> getParserState+ v <- p+ e <- (fromIntegral . stateTokensProcessed) <$> getParserState+ bs@(Bookkeeper {..}) <- get+ let path' = (intercalate "." (reverse path))+ section = t $ default_Section { section_label=(Just . pack) path'+ , section_textSpan=Just $ TextSpan s e+ , section_sentenceList=if length sentences == 0 then Nothing else Just $ V.fromList sentences+ }+ if length path == 0+ then+ put $ bs { communication=communication { communication_sectionList=(cons section) <$> (communication_sectionList communication) }+ , sentences=[]+ , tokens=[]+ }+ else+ put $ bs { communication=communication { communication_sectionList=(cons section) <$> (communication_sectionList communication) }+ , sentences=[]+ , tokens=[]+ }+ return v++-- | Wraps a rule that corresponds to a Communication communicationRule :: (Communication -> Communication) -> CommunicationParser a -> CommunicationParser a communicationRule tr p = do- offset <- (fromIntegral . stateTokensProcessed) <$> getParserState + offset <- (fromIntegral . stateTokensProcessed) <$> getParserState+ bs' <- get+ put $ bs' { offset=offset } (t, o) <- match p bs@(Bookkeeper {..}) <- get let sections = (toList . fromJust) (communication_sectionList communication)@@ -145,24 +213,6 @@ modify (\ bs -> bs { path=(show p'):(tail path) }) return p' --- | Wraps a rule corresponding to a Communication Section-sectionRule :: (Section -> Section) -> CommunicationParser a -> CommunicationParser a-sectionRule t p = do- s <- (fromIntegral . stateTokensProcessed) <$> getParserState- v <- p- e <- (fromIntegral . stateTokensProcessed) <$> getParserState- bs@(Bookkeeper {..}) <- get- let path' = (intercalate "." (reverse path))- section = t $ default_Section { section_label=(Just . pack) path'- , section_textSpan=Just $ TextSpan s e- }- if length path == 0- then- return ()- else- put $ bs { communication=communication { communication_sectionList=(cons section) <$> (communication_sectionList communication) } }- return v- -- | A data structure that is positioned inside a document and whose boundaries can be adjusted class Located a where getTextSpan :: a -> TextSpan@@ -178,3 +228,10 @@ getTextSpan s = (fromJust . section_textSpan) s setTextSpan ts s = s { section_textSpan=Just ts } +instance Located Sentence where+ getTextSpan s = (fromJust . sentence_textSpan) s+ setTextSpan ts s = s { sentence_textSpan=Just ts }++instance Located Token where+ getTextSpan s = (fromJust . token_textSpan) s+ setTextSpan ts s = s { token_textSpan=Just ts }
src/Data/Concrete/Services.hs view
@@ -1,3 +1,7 @@+{-|+Description: Scaffolding and implementations of Concrete services+-}+ module Data.Concrete.Services ( runConcreteService , connectToService , Compression(..)@@ -10,10 +14,13 @@ import System.IO (Handle) import Network (PortID(..), accept) +-- | Compression methods supported by concrete-haskell: the appropriate+-- method is usually determined by file extension. data Compression = BZip | GZip -runConcreteService :: Int -> h -> (h -> (CompactProtocol (FramedTransport Handle), CompactProtocol (FramedTransport Handle)) -> IO Bool) -> IO ()-runConcreteService port handler processor= runThreadedServer acceptor handler processor port'+-- | This function runs an arbitrary Thrift service, threaded, on the given port.+runConcreteService :: Int -> (h -> (CompactProtocol (FramedTransport Handle), CompactProtocol (FramedTransport Handle)) -> IO Bool) -> h -> IO ()+runConcreteService port processor handler = runThreadedServer acceptor handler processor port' where port' = (PortNumber ((read . show) port)) acceptor s = do@@ -21,6 +28,7 @@ t <- openFramedTransport h return (CompactProtocol t, CompactProtocol t) +-- | This function connects as a client to an arbitrary Thrift service on the given host and port. connectToService :: String -> Int -> IO (CompactProtocol (FramedTransport Handle), CompactProtocol (FramedTransport Handle)) connectToService h p = do transport <- hOpen (h, PortNumber $ fromIntegral p)
src/Data/Concrete/Services/Fetch.hs view
@@ -1,9 +1,17 @@-{-# LANGUAGE DeriveGeneric, OverloadedStrings, FlexibleInstances, BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns #-}+{-|+Description: Implementations of FetchCommunicationService for various backends+-} module Data.Concrete.Services.Fetch ( HandleFetch(..)+ , makeHandleFetch , ZipFetch(..)+ , makeZipFetch , TarFetch(..)- , makeTarFetch+ , makeTarFetch , process ) where @@ -35,25 +43,62 @@ import Data.Concrete.Autogen.FetchCommunicationService (process) import Data.List (genericDrop, genericTake, genericLength) import Data.Text.Lazy (Text, pack, unpack)+import Path.IO (resolveFile')+import Control.Monad.IO.Class (liftIO)+import qualified Data.Text.Lazy as T+import Control.Monad (liftM) --- Handle-backed+-- | Handle-based Fetch backend+newtype HandleFetch = HandleFetch Handle -newtype HandleFetch = HandleFetch (Handle, Maybe Compression)+instance Service_Iface HandleFetch where+ about _ = return $ ServiceInfo "Handle-backed FetchCommunicationService" "0.0.1" (Just "Haskell implementation")+ alive _ = return True --- Zip-backed+instance FetchCommunicationService_Iface HandleFetch where+ fetch _ (FetchRequest ii _) = error "unimplemented"+ getCommunicationIDs _ offset count = error "unimplemented"+ getCommunicationCount _ = error "unimplemented" -newtype ZipFetch = ZipFetch (Handle, Maybe Compression)+makeHandleFetch :: String -> IO HandleFetch+makeHandleFetch f = error "unimplemented" --- Tar-backed+-- | Zip-based Fetch backend+newtype ZipFetch = ZipFetch ((Map String Zip.EntrySelector), String) -newtype TarFetch = TarFetch (Handle, (LBS.ByteString -> LBS.ByteString), Tar.TarIndex, Map String FilePath)+instance Service_Iface ZipFetch where+ about _ = return $ ServiceInfo "Zip-backed FetchCommunicationService" "0.0.1" (Just "Haskell implementation")+ alive _ = return True +instance FetchCommunicationService_Iface ZipFetch where+ fetch (ZipFetch (ms, f)) (FetchRequest ii _) = do+ f' <- resolveFile' f+ let ids = map T.unpack (V.toList ii)+ es = map (\i -> ms Map.! i) ids+ ss <- liftIO $ Zip.withArchive f' (sequence $ map (liftM LBS.fromStrict . Zip.getEntry) es)+ cs <- sequence $ map stringToComm ss+ return $ default_FetchResult { fetchResult_communications=V.fromList cs }+ getCommunicationIDs (ZipFetch (ms, f)) offset count = return $ V.fromList $ ((map (pack . fst)) . genericTake count . genericDrop offset . Map.toList) ms+ getCommunicationCount (ZipFetch (ms, f)) = return ((genericLength . Map.toList) ms) +-- | Create a Zip-based Fetch handler based on the given file+makeZipFetch :: String -> IO ZipFetch+makeZipFetch f = do+ f' <- resolveFile' f + es <- liftIO $ Zip.withArchive f' Zip.getEntries+ ms <- Map.fromList <$> mapM (\e -> do+ s <- liftIO $ Zip.withArchive f' (Zip.getEntry e)+ c <- stringToComm (LBS.fromStrict s)+ return (T.unpack $ communication_id c, e)) (Map.keys es)+ return $ ZipFetch (ms, f)++-- | Tar-based Fetch backend+newtype TarFetch = TarFetch (Handle, (LBS.ByteString -> LBS.ByteString), Tar.TarIndex, Map String FilePath)+ instance Service_Iface TarFetch where about _ = return $ ServiceInfo "Tar-backed FetchCommunicationService" "0.0.1" (Just "Haskell implementation") alive _ = return True - instance FetchCommunicationService_Iface TarFetch where fetch (TarFetch (h, c, i, l)) ii = do cc <- sequence $ map fetchOne ((map unpack . V.toList . fetchRequest_communicationIds) ii)@@ -67,7 +112,7 @@ getCommunicationIDs (TarFetch (_, _, _, l)) offset count = return $ V.fromList $ ((map (pack . fst)) . genericTake count . genericDrop offset . Map.toList) l getCommunicationCount (TarFetch (_, _, _, l)) = return ((genericLength . Map.toList) l) -+-- | Create a Tar-based Fetch handler based on the given file makeTarFetch :: String -> IO TarFetch makeTarFetch f = do let c = case takeExtension f of@@ -81,10 +126,8 @@ h' <- openFile f ReadMode return $ TarFetch (h, c, i, Map.fromList l) - commFromEntry :: Tar.Entry -> IO Communication commFromEntry e = stringToComm (((\ (Tar.NormalFile bs _) -> bs) . Tar.entryContent) e)- build :: Tar.Entries e -> IO ([(String, FilePath)], Tar.TarIndex) build = go ([], Tar.empty)
src/Data/Concrete/Services/Store.hs view
@@ -1,10 +1,15 @@ {-# LANGUAGE DeriveGeneric, OverloadedStrings, FlexibleInstances #-}+{-|+Description: Implementations of StoreCommunicationService+-} -module Data.Concrete.Services.Store ( HandleStore(..)- , ZipStore(..)+module Data.Concrete.Services.Store ( ZipStore(..) , TarStore(..)+ , HandleStore(..) , process , makeTarStore+ , makeZipStore+ , makeHandleStore ) where import qualified Data.ByteString as SBS@@ -18,7 +23,7 @@ import System.IO (Handle, hSeek, hTell, hFlush, SeekMode(..)) import qualified Data.Text.Lazy as T import qualified Data.List as L-import Path.IO (resolveFile')+import Path.IO (resolveFile', doesFileExist) import Data.Either (rights) import Path (Path, Dir, File, Abs, filename) import Data.Concrete.Services (Compression(..))@@ -31,16 +36,15 @@ import System.IO (openFile, IOMode(..)) import Control.Monad (liftM) import System.FilePath (takeExtension)+import Control.Monad.IO.Class (liftIO) lift1st :: Monad m => (m a, b) -> m (a, b) lift1st (f, s) = do f' <- f return (f', s) ---- Handle-backed--newtype HandleStore = HandleStore (Handle, Maybe Compression)+-- | Handle-based Store backend+newtype HandleStore = HandleStore (Handle, (LBS.ByteString -> LBS.ByteString)) instance Service_Iface HandleStore where about _ = return $ ServiceInfo "Flat-file-backed StoreCommunicationService" "0.0.1" (Just "Haskell implementation")@@ -49,38 +53,48 @@ instance StoreCommunicationService_Iface HandleStore where store (HandleStore (h, c)) comm = do t <- commToString comm- let c' = case c of- Nothing -> id- Just GZip -> GZip.compress- Just BZip -> BZip.compress- LBS.hPutStr h (c' t)---- Zip-backed+ LBS.hPutStr h (c t) -newtype ZipStore = ZipStore (Handle, Maybe Compression)+makeHandleStore :: String -> IO HandleStore+makeHandleStore f = do+ let c = case takeExtension f of+ ".gz" -> GZip.compress+ ".bz2" -> BZip.compress+ _ -> id+ fd <- openFile f WriteMode+ return $ HandleStore (fd, c)+ +-- | Zip-based Store backend+newtype ZipStore = ZipStore (Path Abs File) -instance Service_Iface (Zip.ZipArchive ()) where+instance Service_Iface ZipStore where about _ = return $ ServiceInfo "Zip-backed StoreCommunicationService" "0.0.1" (Just "Haskell implementation") alive _ = return True -instance StoreCommunicationService_Iface (Zip.ZipArchive ()) where- store _ c = do+instance StoreCommunicationService_Iface ZipStore where+ store (ZipStore f) c = do bs <- commToString c- f <- filename <$> resolveFile' ((T.unpack . communication_id) c)- es <- Zip.mkEntrySelector f- return $ Zip.addEntry Zip.BZip2 (LBS.toStrict bs) es- print $ T.unpack (communication_id c)- return ()+ p <- filename <$> resolveFile' ((T.unpack . communication_id) c)+ es <- Zip.mkEntrySelector p+ Zip.withArchive f $ Zip.addEntry Zip.Deflate (LBS.toStrict bs) es --- Tar-backed+-- | Create a Zip-backed Store handler based on the given file+makeZipStore :: String -> IO ZipStore+makeZipStore f = do+ f' <- resolveFile' f+ e <- doesFileExist f'+ if e == False then Zip.createArchive f' $ return () else return ()+ return $ ZipStore f' +-- | Tar-based Store backend newtype TarStore = TarStore (Handle, (LBS.ByteString -> LBS.ByteString), SBS.ByteString, Integer) +-- | Create a Tar-backed Store handler based on the given file makeTarStore :: String -> IO TarStore makeTarStore f = do (h, c) <- case takeExtension f of- ".tgz" -> lift1st (openFile f WriteMode, GZip.compress)- ".tbz2" -> lift1st (openFile f WriteMode, BZip.compress)+ --".tgz" -> lift1st (openFile f WriteMode, GZip.compress)+ --".tbz2" -> lift1st (openFile f WriteMode, BZip.compress) ".tar" -> lift1st (openFile f WriteMode, id) let pad = LBS.toStrict (c (LBS.replicate (1024) 0)) return $ TarStore (h, c, pad, fromIntegral $ - (SBS.length pad))
src/Data/Concrete/Utils.hs view
@@ -1,4 +1,8 @@ {-# LANGUAGE DeriveGeneric, OverloadedStrings, FlexibleInstances #-}++{-|+Description: Common tools for working with Concrete data+-} module Data.Concrete.Utils ( getUUID@@ -8,7 +12,6 @@ , commToString , incrementUUID , stringToComm- , getSectionText , getCompressor , getDecompressor ) where@@ -16,7 +19,7 @@ import GHC.Generics import Path.IO (resolveFile') import Data.Concrete.Autogen.Communication_Types (Communication(..), default_Communication, read_Communication, write_Communication)-import Data.Concrete.Autogen.Structure_Types (Section(..))+import Data.Concrete.Autogen.Structure_Types (Section(..), Sentence(..), Token(..), Tokenization(..), TokenList(..)) import Data.Concrete.Autogen.Uuid_Types (UUID(..)) import Data.Concrete.Autogen.Metadata_Types (AnnotationMetadata(..), default_AnnotationMetadata) import Data.Concrete.Autogen.Spans_Types (TextSpan(..))@@ -65,6 +68,7 @@ import qualified Data.Binary.Get as G import qualified Control.Monad.Extra as E +-- | Returns appropriate compression based on a file name getCompressor :: String -> (BS.ByteString -> BS.ByteString) getCompressor f = case takeExtension f of ".tgz" -> GZip.compress@@ -73,6 +77,7 @@ ".tbz2" -> BZip.compress _ -> id +-- | Returns appropriate decompression based on a file name getDecompressor :: String -> (BS.ByteString -> BS.ByteString) getDecompressor f = case takeExtension f of ".tgz" -> GZip.decompress@@ -81,25 +86,28 @@ ".tbz2" -> BZip.decompress _ -> id --+-- | Returns a randomly-generated Concrete UUID getUUID :: IO UUID getUUID = do uuid <- (T.pack . toString) <$> nextRandom return $ UUID uuid +-- | Increments the fourth section of a UUID by 1 incrementUUID :: UUID -> UUID incrementUUID (UUID u) = case toWords (fromMaybe nil $ fromString (T.unpack u)) of (a, b, c, d) -> UUID $ (T.pack . toString) (fromWords a b c (d + 1)) +-- | Serialize and write a Communication to a file handle writeCommunication :: Handle -> Communication -> IO () writeCommunication out c = do t <- commToString c BS.hPutStr out t +-- | Convert a Tar entry to a byte string entryToString :: Tar.EntryContent -> BS.ByteString entryToString (Tar.NormalFile s _) = s +-- | A data type for treating strings as Thrift transports data TString = TString ReadBuffer WriteBuffer getWrite :: TString -> WriteBuffer@@ -125,7 +133,8 @@ tPeek (TString r w) = peekBuf r tWrite (TString r w) bs = writeBuf w bs tFlush (TString r w) = flushBuf w >> return ()- ++-- | Convert a Communication to a string using the Compact protocol commToString :: Communication -> IO BS.ByteString commToString c = do otransport <- newTString@@ -133,6 +142,7 @@ write_Communication oproto c flushBuf (getWrite otransport) +-- | Convert a string to a Communication using the Compact protocol stringToComm :: BS.ByteString -> IO Communication stringToComm s = do otransport@(TString r w) <- newTString@@ -140,6 +150,7 @@ let oproto = CompactProtocol otransport read_Communication oproto +-- | Generate a Concrete AnnotationMetadata with the given tool name and current time createAnnotationMetadata :: String -> IO AnnotationMetadata createAnnotationMetadata s = do time <- round `fmap` getPOSIXTime@@ -147,32 +158,45 @@ , annotationMetadata_timestamp=time } +-- | Reconstruct a Token given its Communication's text field+showToken :: T.Text -> Token -> T.Text+showToken t s = substr t (fromIntegral s') (fromIntegral e')+ where+ TextSpan s' e' = (fromJust . token_textSpan) s ++-- | Reconstruct a Sentence given its Communication's text field+showSentence :: T.Text -> Sentence -> T.Text+showSentence t s = if sentence_tokenization s == Nothing then full else T.intercalate " " (L.map (showToken t) (V.toList tokens))+ where+ TextSpan s' e' = (fromJust . sentence_textSpan) s + full = substr t (fromIntegral s') (fromIntegral e')+ tl = (fromJust . join) $ tokenization_tokenList <$> sentence_tokenization s+ tokens = tokenList_tokenList tl++-- | Reconstruct a Section given its Communication's text field showSection :: T.Text -> Section -> T.Text-showSection t s = T.concat [" ", ((fromMaybe "*NO LABEL*" . section_label) s), " == ", t']+showSection t s = if sentences == Nothing then full else T.intercalate "\n" (L.map (showSentence t) (fromJust sentences)) where- TextSpan s' e' = (fromJust . section_textSpan) s+ sentences = V.toList <$> section_sentenceList s+ TextSpan s' e' = (fromJust . section_textSpan) s k = section_kind s t' = substr t (fromIntegral s') (fromIntegral e')--substr :: T.Text -> Int -> Int -> T.Text-substr t s e = res- where- (_, start) = T.splitAt (fromIntegral s) t - res = T.take (fromIntegral $ e - s) start+ full = T.concat [" ", ((fromMaybe "*NO LABEL*" . section_label) s), " == ", t'] +-- | Construct a human-readable Communication showCommunication :: Communication -> T.Text showCommunication c = T.concat [communication_id c, " ", communication_type c, "\n Content sections:\n", T.intercalate "\n" contentSects, "\n ", metadataText] where+ tt = (T.pack . show) c ss = L.concat $ L.map V.toList (maybeToList (communication_sectionList c)) t = (fromJust . communication_text) c contentSects = L.map (showSection t) ((L.filter (\x -> section_kind x == "content")) ss) metadataSects = L.map (fromMaybe "?" . section_label) ((L.filter (\x -> section_kind x /= "content")) ss)- --metadataText = T.intercalate ", " metadataSects metadataText = T.concat [(T.pack . show) (L.length metadataSects), " metadata sections"] -getSectionText :: Communication -> T.Text -> T.Text-getSectionText c n = substr text (fromIntegral s) (fromIntegral e)+-- | Extract a substring from a Text+substr :: T.Text -> Int -> Int -> T.Text+substr t s e = res where- text = fromMaybe (error "No text field!") (communication_text c) - sec = L.filter (\x -> ((fromJust . section_label) x) == n) ((V.toList . fromJust . communication_sectionList) c)- TextSpan s e = (fromJust . section_textSpan) (L.head sec)+ (_, start) = T.splitAt (fromIntegral s) t + res = T.take (fromIntegral $ e - s) start
tests/TestIngesters.hs view
@@ -1,9 +1,13 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedLists #-} module Main (main) where import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BS import Data.Map (toList, (!), keys)+import qualified Data.Map as Map+import Data.Map (Map) import Data.Monoid ((<>)) import Data.List (intercalate) import Control.Monad (void, join, liftM)@@ -18,14 +22,77 @@ import Data.Concrete.Parsers (communicationParsers, ingest) import Data.Concrete.Autogen.Communication_Types (default_Communication, Communication(..)) import Text.Printf (printf)+import qualified Control.Concurrent as C+import qualified Control.Concurrent.STM as S+import qualified Data.Concrete.Services.Store as Store+import qualified Data.Concrete.Services.Fetch as Fetch+import Data.Concrete.Services.Store (ZipStore(..), TarStore(..), HandleStore(..), makeTarStore, makeZipStore, makeHandleStore)+import Data.Concrete.Services.Fetch (ZipFetch(..), TarFetch(..), HandleFetch(..), makeTarFetch, makeZipFetch, makeHandleFetch)+import Data.Concrete.Services (runConcreteService, Compression(..), connectToService)+import qualified Data.Concrete.Autogen.FetchCommunicationService_Client as FetchService+import qualified Data.Concrete.Autogen.StoreCommunicationService_Client as StoreService+import qualified Data.Concrete.Autogen.Service_Client as Service+import Data.Concrete.Autogen.Access_Types (FetchRequest(..), default_FetchRequest, FetchResult(..))+import System.IO.Unsafe+import qualified Codec.Compression.GZip as GZip+import qualified Data.Vector as V + testFormat :: (String, (desc, CommunicationParser (), [String], String)) -> IO () testFormat (f, (d, p, c, i)) = do- let fname = printf "tests/data/example.%s.gz" f :: String- ih <- (liftM GZip.decompress . BS.readFile) fname- putStrLn fname- putStrLn "***********************\n"- ingest (\x -> putStrLn $ unpack $ T.concat [showCommunication x, "\n"]) p (decodeUtf8 ih) c i "concrete-haskell unit test data"+ let inputFile = printf "tests/data/example.%s.gz" f :: String+ putStrLn (printf "\t%s" f :: String)+ con <- connectToService "localhost" 9090+ ih <- (liftM GZip.decompress . BS.readFile) inputFile+ let (_, cp, _, _) = (Map.fromList communicationParsers) ! f+ ingest (\c -> do+ putStrLn $ printf "\t\t%s" (communication_id c)+ StoreService.store con c) p (decodeUtf8 ih) c i "concrete-haskell unit test data" return () -main = putStrLn "\nTesting parsers:" >> (sequence $ map testFormat (communicationParsers))++testFetch :: IO ()+testFetch = do+ putStrLn "Testing fetch service:"+ con <- connectToService "localhost" 9091+ c <- FetchService.getCommunicationCount con+ putStrLn $ printf "\tFetch service reports %d Communications" c+ ids <- FetchService.getCommunicationIDs con 0 c+ putStrLn $ printf "\tReceived %d Communication IDs" (length ids)+ FetchResult {..} <- FetchService.fetch con $ default_FetchRequest { fetchRequest_communicationIds=ids }+ sequence $ map (putStrLn . printf "\t\tFetched Communication with ID == %s" . T.unpack . communication_id) (V.toList fetchResult_communications)+ return ()+ ++main = do+ putStrLn "\nTesting parsers + fetch and store services:"+ let outputFile = "test.tar"+ store <- C.forkIO $ do+ case takeExtension outputFile of+ ".zip" -> do+ h <- makeZipStore outputFile+ runConcreteService 9090 Store.process h+ ".tar" -> do+ h <- makeTarStore outputFile+ runConcreteService 9090 Store.process h+ _ -> do+ h <- makeHandleStore outputFile+ runConcreteService 9090 Store.process h+ C.threadDelay 1000000+ sequence $ map testFormat (communicationParsers)+ C.killThread store+ C.threadDelay 1000000+ fetch <- C.forkIO $ do+ case takeExtension outputFile of+ ".zip" -> do+ h <- makeZipFetch outputFile+ runConcreteService 9091 Fetch.process h+ ".tar" -> do+ h <- makeTarFetch outputFile+ runConcreteService 9091 Fetch.process h+ _ -> do+ h <- makeHandleFetch outputFile+ runConcreteService 9091 Fetch.process h+ C.threadDelay 1000000+ testFetch+ C.killThread fetch
− tests/TestSerialization.hs
@@ -1,22 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Main (main) where--import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy as BS-import Data.Map (toList, (!), keys)-import Data.Monoid ((<>))-import Data.List (intercalate)-import Control.Monad (void, join, liftM)-import Data.Text.Lazy (Text, unpack, take)-import qualified Data.Text.Lazy as T-import Data.Text.Lazy.Encoding (decodeUtf8)-import System.IO (stdin, stdout, stderr, openFile, Handle, IOMode(..), hPutStrLn)-import System.FilePath (takeExtension)-import qualified Codec.Compression.GZip as GZip-import Data.Concrete.Utils (writeCommunication, showCommunication)-import Data.Concrete.Parsers.Types (CommunicationParser)-import Data.Concrete.Parsers (communicationParsers, ingest)-import Data.Concrete.Autogen.Communication_Types (default_Communication, Communication(..))-import Text.Printf (printf)--main = return ()
utils/FetchService.hs view
@@ -4,12 +4,13 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ExplicitNamespaces #-} module Main (main) where import System.FilePath (takeExtension)-import Data.Concrete.Services.Fetch (ZipFetch(..), TarFetch(..), HandleFetch(..), process, makeTarFetch)+import Data.Concrete.Services.Fetch (ZipFetch(..), TarFetch(..), process, makeTarFetch, makeZipFetch) import Data.Concrete.Services (runConcreteService, Compression(..)) import Options.Generic (Generic, ParseRecord, Unwrapped, Wrapped, unwrapRecord, (:::), type (<?>)(..)) import System.IO (openFile, IOMode(..))@@ -23,7 +24,12 @@ deriving instance Show (Parameters Unwrapped) main = do- ps <- unwrapRecord "Run a file-backed Store service: supports .tar and .tgz"- let f = file ps - h <- makeTarFetch f- runConcreteService (port ps) h process+ ps <- unwrapRecord "Run a file-backed Fetch service: supports .tar and .zip"+ let f = file ps+ case takeExtension f of+ ".zip" -> do+ h <- makeZipFetch f+ runConcreteService (port ps) process h+ ".tar" -> do+ h <- makeTarFetch f+ runConcreteService (port ps) process h
utils/InspectCommunications.hs view
@@ -14,7 +14,8 @@ import qualified Data.Concrete.Utils as CU import Data.Concrete.Autogen.Communication_Types (default_Communication, Communication(..)) import qualified Data.Concrete.Autogen.FetchCommunicationService_Client as FetchService-import Data.Concrete.Autogen.Access_Types (FetchRequest(..))+import Data.Concrete.Autogen.FetchCommunicationService_Iface (FetchCommunicationService_Iface(fetch, getCommunicationIDs, getCommunicationCount))+import Data.Concrete.Autogen.Access_Types (FetchRequest(..), default_FetchRequest, FetchResult(..)) import Data.Concrete.Services (connectToService) import qualified Data.Vector as V import Control.Monad (liftM, mapM, join)@@ -24,7 +25,9 @@ import System.IO (stdin, stdout, stderr, openFile, Handle, IOMode(..), hPutStrLn) import System.FilePath (takeExtension) import Options.Generic+import Data.Concrete.Services.Fetch (ZipFetch(..), TarFetch(..), process, makeTarFetch, makeZipFetch, makeHandleFetch) + data Parameters w = Parameters { inputFile :: w ::: Maybe String <?> "Input file, possibly compressed (.bz2 or .gz)" , start :: w ::: Maybe Int <?> "Index of first Communication to show" , end :: w ::: Maybe Int <?> "Index of last Communication to show"@@ -33,32 +36,32 @@ } deriving (Generic) + instance ParseRecord (Parameters Wrapped) deriving instance Show (Parameters Unwrapped) ++fetchDirect :: FetchCommunicationService_Iface a => a -> IO FetchResult+fetchDirect h = do+ c <- getCommunicationCount h+ cs <- getCommunicationIDs h 0 c+ fetch h $ default_FetchRequest { fetchRequest_communicationIds=cs }++ main = do ps <- unwrapRecord "Inspect Concrete Communications" let s = start ps e = end ps cb = (\x -> (putStrLn . T.unpack) (CU.showCommunication x))- cs <- case inputFile ps of+ FetchResult cs <- case inputFile ps of Nothing -> do con <- connectToService ((fromMaybe "0.0.0.0" . host) ps) ((fromMaybe 9090 . port) ps) c <- FetchService.getCommunicationCount con- print c l <- FetchService.getCommunicationIDs con 0 c- --print l- c' <- FetchService.fetch con (FetchRequest (V.drop 50 l) Nothing)- print c'- return ()+ FetchService.fetch con (FetchRequest l Nothing) Just f -> case takeExtension f of- --".tar" -> CU.readCommunicationsFromTar <$> (BS.readFile f)- --".tgz" -> CU.readCommunicationsFromTar <$> ((liftM GZip.decompress . BS.readFile) f)- --".tbz2" -> CU.readCommunicationsFromTar <$> ((liftM BZip.decompress . BS.readFile) f)- --".zip" -> return $ CU.readCommunicationsFromZip f- --".bz2" -> CU.mapCommunicationsFromBytes cb s e <$> ((liftM BZip.decompress . BS.readFile) f)- --".gz" -> CU.mapCommunicationsFromBytes cb s e <$> ((liftM GZip.decompress . BS.readFile) f)- _ -> error "unimplemented" --CU.mapCommunicationsFromBytes cb s e <$> (BS.readFile f)- --Nothing -> CU.readCommunicationsFromBytes <$> (BS.hGetContents stdin)+ ".tar" -> join $ fetchDirect <$> makeTarFetch f+ ".zip" -> join $ fetchDirect <$> makeZipFetch f+ print $ length cs return ()
utils/StoreService.hs view
@@ -9,7 +9,7 @@ module Main (main) where import System.FilePath (takeExtension)-import Data.Concrete.Services.Store (ZipStore(..), TarStore(..), HandleStore(..), process, makeTarStore)+import Data.Concrete.Services.Store (ZipStore(..), TarStore(..), process, makeTarStore, makeZipStore) import Data.Concrete.Services (runConcreteService, Compression(..)) import Options.Generic (Generic, ParseRecord, Unwrapped, Wrapped, unwrapRecord, (:::), type (<?>)(..)) import System.IO (openFile, IOMode(..))@@ -25,5 +25,10 @@ main = do ps <- unwrapRecord "Run a file-backed Store service: supports .tar and .tgz" let f = file ps- h <- makeTarStore f- runConcreteService (port ps) h process+ case takeExtension f of+ --".zip" -> do+ -- h <- makeZipStore f+ -- runConcreteService (port ps) process h+ ".tar" -> do+ h <- makeTarStore f+ runConcreteService (port ps) process h