warc 0.1.1.1 → 0.2.0
raw patch · 4 files changed
+259/−54 lines, 4 filesdep +exceptionsdep +filepathdep +mmorphdep −eitherdep ~attoparsecdep ~basedep ~bytestringnew-component:exe:warc-export
Dependencies added: exceptions, filepath, mmorph, optparse-applicative, pipes-zlib, warc
Dependencies removed: either
Dependency ranges changed: attoparsec, base, bytestring, errors, free, lens, pipes, pipes-attoparsec, pipes-bytestring, text, time, transformers
Files
- Data/Warc.hs +55/−30
- Data/Warc/Header.hs +104/−17
- WarcExport.hs +71/−0
- warc.cabal +29/−7
Data/Warc.hs view
@@ -1,68 +1,93 @@ {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-} module Data.Warc ( Record(..) , Warc(..)+ -- * Parsing , parseWarc , iterRecords+ , produceRecords+ -- * Encoding+ , encodeRecord+ -- * Headers+ , module Data.Warc.Header ) where import Data.Char (ord)-import Pipes (Producer, yield)+import Pipes hiding (each) import qualified Pipes.ByteString as PBS import Control.Lens import qualified Pipes.Attoparsec as PA import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy.Builder as BB import Data.ByteString (ByteString)-import Control.Monad (void)-import Control.Monad.Trans.Class-import Control.Monad.Trans.Either+import Control.Monad (join) import Control.Monad.Trans.Free import Control.Monad.Trans.State.Strict-import Control.Error import Data.Warc.Header + -- | A WARC record-data Record m r = Record { recWarcVersion :: Version- , recHeader :: [Field]- , recContent :: Producer BS.ByteString m r+data Record m r = Record { recHeader :: RecordHeader+ , recContent :: Producer BS.ByteString m r } instance Monad m => Functor (Record m) where- fmap f (Record ver hdr r) = Record ver hdr (fmap f r)+ fmap f (Record hdr r) = Record hdr (fmap f r) -- | A WARC archive-data Warc m = Warc (FreeT (Record m) m (Producer BS.ByteString m ()))--instance Monad m => Monoid (Warc m) where- Warc a `mappend` Warc b = Warc (a >> b)- mempty = Warc (return (return ()))+type Warc m a = FreeT (Record m) m (Producer BS.ByteString m a) -parseWarc :: (Functor m, Monad m) => Producer ByteString m () -> Warc m-parseWarc = Warc . loop+-- | Parse a WARC archive.+parseWarc :: (Functor m, Monad m)+ => Producer ByteString m a+ -> Warc m a+parseWarc = loop where loop upstream = FreeT $ do (hdr, rest) <- runStateT (PA.parse header) upstream go hdr rest - go hdr rest- | Nothing <- hdr = return $ Pure rest- | Just (Left err) <- hdr = error $ show err- | Just (Right (ver, fields)) <- hdr = do- let [len] = toListOf (each . _ContentLength) fields+ go mhdr rest+ | Nothing <- mhdr = return $ Pure rest+ | Just (Left err) <- mhdr = error $ show err+ | Just (Right hdr) <- mhdr+ , Just len <- hdr ^? recHeaders . each . _ContentLength = do let produceBody = fmap consumeWhitespace . view (PBS.splitAt len) consumeWhitespace = PBS.dropWhile isEOL isEOL c = c == ord8 '\r' || c == ord8 '\n' ord8 = fromIntegral . ord- return $ Free $ Record ver fields $ fmap loop $ produceBody rest+ return $ Free $ Record hdr $ fmap loop $ produceBody rest -iterRecords :: Monad m => (forall a. Record m a -> m a) -> Warc m -> m (Producer BS.ByteString m ())-iterRecords f (Warc free) = go free+-- | Iterate over the 'Record's in a WARC archive+iterRecords :: forall m a. Monad m+ => (forall b. Record m b -> m b)+ -> Warc m a+ -> m (Producer BS.ByteString m a)+iterRecords f warc = iterT iter warc where- go (FreeT action) = action >>= \next -> do- case next of- Pure a -> return a- Free record -> do- rest <- f record- go rest+ iter :: Record m (m (Producer BS.ByteString m a))+ -> m (Producer BS.ByteString m a)+ iter r = join $ f r++produceRecords :: forall m o a. Monad m+ => (forall b. RecordHeader -> Producer BS.ByteString m b+ -> Producer o m b)+ -- ^ consume the record producing some output+ -> Warc m a+ -- ^ a WARC archive (see 'parseWarc')+ -> Producer o m (Producer BS.ByteString m a)+ -- ^ returns any leftovers+produceRecords f warc = iterTM iter warc+ where+ iter :: Record m (Producer o m (Producer BS.ByteString m a))+ -> Producer o m (Producer BS.ByteString m a)+ iter (Record hdr body) = join $ f hdr body++encodeRecord :: Monad m => Record m a -> Producer BS.ByteString m a+encodeRecord (Record hdr content) = do+ PBS.fromLazy $ BB.toLazyByteString $ encodeHeader hdr+ content
Data/Warc/Header.hs view
@@ -2,12 +2,15 @@ {-# LANGUAGE TemplateHaskell #-} module Data.Warc.Header- ( Version(..)+ ( RecordHeader(..)+ , Version(..) , WarcType (..) , RecordId (..) , TruncationReason (..) , Digest (..)+ , Uri (..) , header+ , encodeHeader -- * Header field types , Field (..) -- ** Prisms@@ -30,6 +33,8 @@ , _WarcSegmentNumber , _WarcSegmentOriginId , _WarcSegmentTotalLength+ -- * Lenses+ , recWarcVersion, recHeaders ) where import Control.Applicative@@ -47,6 +52,7 @@ import qualified Data.Text.Lazy as TL import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Builder as BB import Control.Lens @@ -139,20 +145,46 @@ , "continuation" *> pure Continuation , FutureType <$> utf8Token ]- -newtype RecordId = RecordId ByteString- deriving (Show, Read, Eq, Ord) -uri :: Parser ByteString+encodeText :: T.Text -> BB.Builder+encodeText = BB.byteString . TE.encodeUtf8++encodeWarcType :: WarcType -> BB.Builder+encodeWarcType WarcInfo = "warcinfo"+encodeWarcType Response = "response"+encodeWarcType Resource = "resource"+encodeWarcType Request = "request"+encodeWarcType Metadata = "metadata"+encodeWarcType Revisit = "revisit"+encodeWarcType Conversion = "conversion"+encodeWarcType Continuation = "continuation"+encodeWarcType (FutureType t) = encodeText t++newtype Uri = Uri ByteString+ deriving (Show, Read, Eq, Ord)++uri :: Parser Uri uri = do char '<' s <- takeTill (== '>') char '>'- return s+ return $ Uri s +laxUri :: Parser Uri+laxUri = Uri <$> takeTill (isEndOfLine . ord')++encodeUri :: Uri -> BB.Builder+encodeUri (Uri b) = BB.char7 '<' <> BB.byteString b <> BB.char7 '>'++newtype RecordId = RecordId Uri+ deriving (Show, Read, Eq, Ord)+ recordId :: Parser RecordId recordId = RecordId <$> uri +encodeRecordId :: RecordId -> BB.Builder+encodeRecordId (RecordId r) = encodeUri r+ data TruncationReason = TruncLength | TruncTime | TruncDisconnect@@ -169,6 +201,13 @@ , TruncOther <$> utf8Token ] +encodeTruncationReason :: TruncationReason -> BB.Builder+encodeTruncationReason TruncLength = "length"+encodeTruncationReason TruncTime = "time"+encodeTruncationReason TruncDisconnect = "disconnect"+encodeTruncationReason TruncUnspecified = "unspecified"+encodeTruncationReason (TruncOther o) = encodeText o+ data Digest = Digest { digestAlgorithm, digestHash :: !ByteString } deriving (Show, Read, Eq, Ord) @@ -178,21 +217,25 @@ hash <- token return $ Digest algo hash +encodeDigest :: Digest -> BB.Builder+encodeDigest (Digest algo hash) =+ BB.byteString algo <> ":" <> BB.byteString hash+ data Field = WarcRecordId !RecordId | ContentLength !Integer | WarcDate !UTCTime | WarcType !WarcType | ContentType !ByteString- | WarcConcurrentTo [RecordId]+ | WarcConcurrentTo !RecordId | WarcBlockDigest !Digest | WarcPayloadDigest !Digest | WarcIpAddress !ByteString- | WarcRefersTo !ByteString- | WarcTargetUri !ByteString+ | WarcRefersTo !Uri+ | WarcTargetUri !Uri | WarcTruncated !TruncationReason | WarcWarcinfoId !RecordId | WarcFilename !Text- | WarcProfile !ByteString+ | WarcProfile !Uri | WarcIdentifiedPayloadType !ByteString | WarcSegmentNumber !Integer | WarcSegmentOriginId !ByteString@@ -204,9 +247,13 @@ date :: Parser UTCTime date = do s <- takeTill isSpace- parseTimeM False defaultTimeLocale fmt (BS.unpack s)- where fmt = iso8601DateFormat (Just "%H:%M:%SZ")- + parseTimeM False defaultTimeLocale dateFormat (BS.unpack s)++encodeDate :: UTCTime -> BB.Builder+encodeDate = BB.string7 . formatTime defaultTimeLocale dateFormat++dateFormat = iso8601DateFormat (Just "%H:%M:%SZ")+ warcField :: Parser Field warcField = choice [ field "WARC-Record-ID" (WarcRecordId <$> recordId)@@ -214,12 +261,12 @@ , field "WARC-Date" (WarcDate <$> date) , field "WARC-Type" (WarcType <$> warcType) , field "Content-Type" (ContentType <$> takeTill (isEndOfLine . ord'))- , field "WARC-Concurrent-To" (WarcConcurrentTo <$> many1 recordId)+ , field "WARC-Concurrent-To" (WarcConcurrentTo <$> recordId) , field "WARC-Block-Digest" (WarcBlockDigest <$> digest) , field "WARC-Payload-Digest" (WarcPayloadDigest <$> digest) , field "WARC-IP-Address" (WarcIpAddress <$> takeTill (isEndOfLine . ord')) , field "WARC-Refers-To" (WarcRefersTo <$> uri)- , field "WARC-Target-URI" (WarcTargetUri <$> takeTill (isEndOfLine . ord'))+ , field "WARC-Target-URI" (WarcTargetUri <$> laxUri) , field "WARC-Truncated" (WarcTruncated <$> truncationReason) , field "WARC-Warcinfo-ID" (WarcWarcinfoId <$> recordId) , field "WARC-Filename" (WarcFilename <$> (text <|> quotedString))@@ -230,12 +277,52 @@ , field "WARC-Segment-Total-Length" (WarcSegmentTotalLength <$> decimal) ] +data RecordHeader = RecordHeader { _recWarcVersion :: Version+ , _recHeaders :: [Field]+ }+ deriving (Show)++makeLenses ''RecordHeader+ -- | A WARC header-header :: Parser (Version, [Field])+header :: Parser RecordHeader header = withName "header" $ do skipSpace ver <- version <* endOfLine let unknownField = field token (takeTill (isEndOfLine . ord') *> return Nothing) fields <- withName "fields" $ many $ (Just <$> warcField) <|> unknownField endOfLine- return (ver, catMaybes fields)+ return $ RecordHeader ver (catMaybes fields)++encodeHeader :: RecordHeader -> BB.Builder+encodeHeader (RecordHeader (Version maj min) flds) =+ "WARC/"<>BB.intDec maj<>"."<>BB.intDec min <> "\n"+ <> foldMap encodeField flds+ <> BB.char7 '\n'++encodeField :: Field -> BB.Builder+encodeField fld =+ case fld of+ WarcRecordId r -> field "WARC-Record-ID" (encodeRecordId r)+ ContentLength len -> field "Content-Length" (BB.integerDec len)+ WarcDate t -> field "WARC-Date" (encodeDate t)+ WarcType t -> field "WARC-Type" (encodeWarcType t)+ ContentType t -> field "Content-Type" (BB.byteString t)+ WarcConcurrentTo r -> field "WARC-Concurrent-To" (encodeRecordId r)+ WarcBlockDigest d -> field "WARC-Block-Digest" (encodeDigest d)+ WarcPayloadDigest d -> field "WARC-Payload-Digest" (encodeDigest d)+ WarcIpAddress addr -> field "WARC-IP-Address" (BB.byteString addr)+ WarcRefersTo uri -> field "WARC-Refers-To" (encodeUri uri)+ WarcTargetUri uri -> field "WARC-Target-URI" (encodeUri uri)+ WarcTruncated t -> field "WARC-Truncated" (encodeTruncationReason t)+ WarcWarcinfoId r -> field "WARC-Warcinfo-ID" (encodeRecordId r)+ WarcFilename n -> field "WARC-Filename" (quoted $ encodeText n)+ WarcProfile uri -> field "WARC-Profile" (encodeUri uri)+ WarcSegmentNumber n -> field "WARC-Segment-Number" (BB.integerDec n)+ WarcSegmentTotalLength len -> field "WARC-Segment-Total-Length" (BB.integerDec len)+ where+ field :: BB.Builder -> BB.Builder -> BB.Builder+ field name val = name <> ": " <> val <> BB.char7 '\n'++ quoted x = q <> x <> q+ where q = BB.char7 '"'
+ WarcExport.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE OverloadedStrings #-}++import Data.List (isSuffixOf)+import Control.Applicative+import System.IO+import System.FilePath++import Data.Attoparsec.ByteString.Char8+import qualified Data.Text as T+import qualified Data.ByteString as BS+import Control.Monad.IO.Class+import Control.Monad.Catch++import Control.Lens+import Data.Text.Lens+import Pipes hiding (each)+import qualified Pipes.ByteString as PBS+import qualified Pipes.GZip as GZip+import qualified Pipes.Prelude as PP+import Data.Warc+import Data.Warc.Header+import Options.Applicative as O hiding (header)++withFileProducer :: (MonadIO m, MonadMask m)+ => FilePath+ -> (Producer BS.ByteString m () -> m a)+ -> m a+withFileProducer path action = bracket (liftIO $ openFile path ReadMode) (liftIO . hClose) $ \h ->+ let prod+ | ".gz" `isSuffixOf` path = hoist liftIO $ GZip.decompress $ PBS.fromHandle h+ | otherwise = PBS.fromHandle h+ in action prod++testHeader = do+ f <- BS.readFile "bbc.warc"+ print $ parse header f++outFile :: Record m a -> Maybe FilePath+outFile r = fileName <|> recId+ where+ fileName = recHeader r ^? recHeaders . each . _WarcFilename . _Text+ recId = recHeader r ^? recHeaders . each . _WarcRecordId . to recIdToFileName+ recIdToFileName (RecordId (Uri uri)) = "hello"++doExport :: FilePath -> FilePath -> IO ()+doExport outDir warcPath = do+ let go :: Record IO a -> IO a+ go r =+ case outFile r of+ Nothing -> runEffect $ recContent r >-> PP.drain+ Just outName -> withFile (outDir </> outName) WriteMode $ \outH -> do+ putStrLn outName+ runEffect $ recContent r >-> PBS.toHandle outH++ withFileProducer warcPath $ \prod -> do+ rest <- iterRecords go $ parseWarc prod+ putStrLn "That was all. This is left over..."+ runEffect $ rest >-> PBS.toHandle stdout+ return ()+++args :: O.Parser (IO ())+args =+ doExport <$> O.option str (short 'C' <> long "directory" <> metavar "DIR"+ <> help "Directory to place output in")+ <*> O.argument str (metavar "FILE" <> help "The WARC file to export")++main :: IO ()+main = do+ action <- execParser (info (helper <*> args) mempty)+ action
warc.cabal view
@@ -1,5 +1,5 @@ name: warc-version: 0.1.1.1+version: 0.2.0 synopsis: A parser for the Web Archive (WARC) format description: A streaming parser for the Web Archive (WARC) format. homepage: http://github.com/bgamari/warc@@ -19,17 +19,39 @@ library exposed-modules: Data.Warc, Data.Warc.Header other-extensions: RankNTypes, OverloadedStrings, TemplateHaskell- build-depends: base >=4.8 && <4.9,+ build-depends: base >=4.8 && <4.10, pipes >=4.1 && <4.2, attoparsec >=0.12 && <0.14, bytestring >=0.10 && <0.11, pipes-bytestring >=2.1 && <2.2,- transformers >=0.4 && <0.5,- lens >=4.7 && <4.13,+ transformers >=0.4 && <0.6,+ lens >=4.7 && <4.14, pipes-attoparsec >=0.5 && <0.6,- either >=4.3 && <4.5, free >=4.10 && <4.13, errors >=1.4 && <3.0,- time >=1.5 && <1.6,- text >=1.2 && <1.3+ time >=1.5 && <1.7,+ text >=1.2 && <1.3,+ mmorph >= 1.0 && <1.1+ default-language: Haskell2010++executable warc-export+ main-is: WarcExport.hs+ other-extensions: RankNTypes, OverloadedStrings, TemplateHaskell+ build-depends: base,+ warc,+ filepath,+ exceptions,+ pipes-zlib,+ optparse-applicative,+ pipes,+ attoparsec,+ bytestring,+ pipes-bytestring,+ transformers,+ lens,+ pipes-attoparsec,+ free,+ errors,+ time,+ text default-language: Haskell2010