warc 0.3.1 → 1.0.1
raw patch · 6 files changed
+517/−452 lines, 6 filesdep +hashabledep +unordered-containersdep ~base
Dependencies added: hashable, unordered-containers
Dependency ranges changed: base
Files
- Data/Warc.hs +0/−114
- Data/Warc/Header.hs +0/−331
- WarcExport.hs +6/−4
- src/Data/Warc.hs +114/−0
- src/Data/Warc/Header.hs +391/−0
- warc.cabal +6/−3
− Data/Warc.hs
@@ -1,114 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE GADTs #-}---- | WARC (or Web ARCive) is a archival file format widely used to distribute--- corpora of crawled web content (see, for instance the Common Crawl corpus). A--- WARC file consists of a set of records, each of which describes a web request--- or response.------ This module provides a streaming parser and encoder for WARC archives for use--- with the @pipes@ package.----module Data.Warc- ( Warc(..)- , Record(..)- -- * Parsing- , parseWarc- , iterRecords- , produceRecords- -- * Encoding- , encodeRecord- -- * Headers- , module Data.Warc.Header- ) where--import Data.Char (ord)-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 (join)-import Control.Monad.Trans.Free-import Control.Monad.Trans.State.Strict--import Data.Warc.Header----- | A WARC record------ This represents a single record of a WARC file, consisting of a set of--- headers and a means of producing the record's body.-data Record m r = Record { recHeader :: RecordHeader- -- ^ the WARC headers- , recContent :: Producer BS.ByteString m r- -- ^ the body of the record- }--instance Monad m => Functor (Record m) where- fmap f (Record hdr r) = Record hdr (fmap f r)---- | A WARC archive.------ This represents a sequence of records followed by whatever data--- was leftover from the parse.-type Warc m a = FreeT (Record m) m (Producer BS.ByteString m a)---- | Parse a WARC archive.------ Note that this function does not actually do any parsing itself;--- it merely returns a 'Warc' value which can then be run to parse--- individual records.-parseWarc :: (Functor m, Monad m)- => Producer ByteString m a -- ^ a producer of a stream of WARC content- -> Warc m a -- ^ the parsed WARC archive-parseWarc = loop- where- loop upstream = FreeT $ do- (hdr, rest) <- runStateT (PA.parse header) upstream- go hdr rest-- 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 hdr $ fmap loop $ produceBody rest---- | Iterate over the 'Record's in a WARC archive-iterRecords :: forall m a. Monad m- => (forall b. Record m b -> m b) -- ^ the action to run on each 'Record'- -> Warc m a -- ^ the 'Warc' file- -> m (Producer BS.ByteString m a) -- ^ returns any leftover data-iterRecords f warc = iterT iter warc- where- 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 leftover data-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---- | Encode a 'Record' in WARC format.-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
@@ -1,331 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}--module Data.Warc.Header- ( -- * Parsing- header- -- * Encoding- , encodeHeader- -- * Types- , RecordHeader(..)- , Version(..)- , WarcType(..)- , RecordId(..)- , TruncationReason(..)- , Digest(..)- , Uri(..)- -- * Header field types- , Field(..)- -- ** Prisms- , _WarcRecordId- , _ContentLength- , _WarcDate- , _WarcType- , _ContentType- , _WarcConcurrentTo- , _WarcBlockDigest- , _WarcPayloadDigest- , _WarcIpAddress- , _WarcRefersTo- , _WarcTargetUri- , _WarcTruncated- , _WarcWarcinfoId- , _WarcFilename- , _WarcProfile- , _WarcIdentifiedPayloadType- , _WarcSegmentNumber- , _WarcSegmentOriginId- , _WarcSegmentTotalLength- -- * Lenses- , recWarcVersion, recHeaders- ) where--import Control.Applicative-import Control.Monad (void)-import Data.Maybe (catMaybes)-import Data.Monoid ((<>))-import Data.Time.Clock-import Data.Time.Format-import Data.Char (ord)--import Data.Attoparsec.ByteString.Char8-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-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--withName :: String -> Parser a -> Parser a-withName name parser = parser <?> name--data Version = Version {versionMajor, versionMinor :: !Int}- deriving (Show, Read, Eq, Ord)--version :: Parser Version-version = withName "version" $ do- "WARC/"- major <- decimal- char '.'- minor <- decimal- return (Version major minor)--newtype FieldName = FieldName {getFieldName :: Text}- deriving (Show, Read)--instance Eq FieldName where- FieldName a == FieldName b = T.toCaseFold a == T.toCaseFold b--instance Ord FieldName where- FieldName a `compare` FieldName b = T.toCaseFold a `compare` T.toCaseFold b--separators :: String-separators = "()<>@,;:\\\"/[]?={}"--crlf :: Parser ()-crlf = void $ string "\r\n"--token :: Parser ByteString-token = takeTill (inClass $ separators++" \t\n\r")--utf8Token :: Parser Text-utf8Token = TE.decodeUtf8 <$> token--fieldName :: Parser FieldName-fieldName = FieldName . TE.decodeUtf8 <$> token--ord' = fromIntegral . ord--text :: Parser Text-text = do- let content :: TL.Text -> Parser TL.Text- content accum = do- satisfy (isHorizontalSpace . ord')- c <- takeTill (isEndOfLine . ord')- continuation (accum <> TL.fromStrict (TE.decodeUtf8 c))- continuation :: TL.Text -> Parser TL.Text- continuation accum = content accum <|> return accum- firstLine <- takeTill (isEndOfLine . ord')- TL.toStrict <$> continuation (TL.fromStrict $ TE.decodeUtf8 firstLine)--quotedString :: Parser Text-quotedString = do- char '"'- c <- TE.decodeUtf8 <$> takeTill (== '"')- char '"'- return c--field :: Parser name -> Parser a -> Parser a-field name content = do- try name- char ':'- skipSpace- content <* endOfLine--data WarcType = WarcInfo- | Response- | Resource- | Request- | Metadata- | Revisit- | Conversion- | Continuation- | FutureType !Text- deriving (Show, Read, Ord, Eq)--warcType :: Parser WarcType-warcType = choice- [ "warcinfo" *> pure WarcInfo- , "response" *> pure Response- , "resource" *> pure Resource- , "request" *> pure Request- , "metadata" *> pure Metadata- , "revisit" *> pure Revisit- , "conversion" *> pure Conversion- , "continuation" *> pure Continuation- , FutureType <$> utf8Token- ]--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 $ 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- | TruncUnspecified- | TruncOther !Text- deriving (Show, Read, Ord, Eq)--truncationReason :: Parser TruncationReason-truncationReason = choice- [ "length" *> pure TruncLength- , "time" *> pure TruncTime- , "disconnect" *> pure TruncDisconnect- , "unspecified" *> pure TruncUnspecified- , 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)--digest :: Parser Digest-digest = do- algo <- token <* char ':'- 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- | WarcBlockDigest !Digest- | WarcPayloadDigest !Digest- | WarcIpAddress !ByteString- | WarcRefersTo !Uri- | WarcTargetUri !Uri- | WarcTruncated !TruncationReason- | WarcWarcinfoId !RecordId- | WarcFilename !Text- | WarcProfile !Uri- | WarcIdentifiedPayloadType !ByteString- | WarcSegmentNumber !Integer- | WarcSegmentOriginId !ByteString- | WarcSegmentTotalLength !Integer- deriving (Show, Read)--makePrisms ''Field--date :: Parser UTCTime-date = do- s <- takeTill isSpace- 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)- , field "Content-Length" (ContentLength <$> decimal)- , field "WARC-Date" (WarcDate <$> date)- , field "WARC-Type" (WarcType <$> warcType)- , field "Content-Type" (ContentType <$> takeTill (isEndOfLine . ord'))- , 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 <$> laxUri)- , field "WARC-Truncated" (WarcTruncated <$> truncationReason)- , field "WARC-Warcinfo-ID" (WarcWarcinfoId <$> recordId)- , field "WARC-Filename" (WarcFilename <$> (text <|> quotedString))- , field "WARC-Profile" (WarcProfile <$> uri)- -- , field "WARC-Identified-Payload-Type" (WarcIdentifiedPayloadType <$> mediaType)- , field "WARC-Segment-Number" (WarcSegmentNumber <$> decimal)- --, field "WARC-Segment-Origin-ID" (WarcSegmentOriginId <$> msgId)- , field "WARC-Segment-Total-Length" (WarcSegmentTotalLength <$> decimal)- ]--data RecordHeader = RecordHeader { _recWarcVersion :: Version- , _recHeaders :: [Field]- }- deriving (Show)--makeLenses ''RecordHeader---- | A WARC header-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 $ 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
@@ -8,7 +8,7 @@ import Data.Attoparsec.ByteString.Char8 import qualified Data.Text as T-import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS import Control.Monad.IO.Class import Control.Monad.Catch @@ -39,9 +39,11 @@ 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"+ fileName = r ^? to recHeader . field warcFilename . _Text+ recId = r ^? to recHeader . field warcRecordId . to recIdToFileName+ recIdToFileName (RecordId (Uri uri)) = map escape $ BS.unpack uri+ where escape '/' = '-'+ escape c = c doExport :: FilePath -> FilePath -> IO () doExport outDir warcPath = do
+ src/Data/Warc.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}++-- | WARC (or Web ARCive) is a archival file format widely used to distribute+-- corpora of crawled web content (see, for instance the Common Crawl corpus). A+-- WARC file consists of a set of records, each of which describes a web request+-- or response.+--+-- This module provides a streaming parser and encoder for WARC archives for use+-- with the @pipes@ package.+--+module Data.Warc+ ( Warc(..)+ , Record(..)+ -- * Parsing+ , parseWarc+ , iterRecords+ , produceRecords+ -- * Encoding+ , encodeRecord+ -- * Headers+ , module Data.Warc.Header+ ) where++import Data.Char (ord)+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 (join)+import Control.Monad.Trans.Free+import Control.Monad.Trans.State.Strict++import Data.Warc.Header+++-- | A WARC record+--+-- This represents a single record of a WARC file, consisting of a set of+-- headers and a means of producing the record's body.+data Record m r = Record { recHeader :: RecordHeader+ -- ^ the WARC headers+ , recContent :: Producer BS.ByteString m r+ -- ^ the body of the record+ }++instance Monad m => Functor (Record m) where+ fmap f (Record hdr r) = Record hdr (fmap f r)++-- | A WARC archive.+--+-- This represents a sequence of records followed by whatever data+-- was leftover from the parse.+type Warc m a = FreeT (Record m) m (Producer BS.ByteString m a)++-- | Parse a WARC archive.+--+-- Note that this function does not actually do any parsing itself;+-- it merely returns a 'Warc' value which can then be run to parse+-- individual records.+parseWarc :: (Functor m, Monad m)+ => Producer ByteString m a -- ^ a producer of a stream of WARC content+ -> Warc m a -- ^ the parsed WARC archive+parseWarc = loop+ where+ loop upstream = FreeT $ do+ (hdr, rest) <- runStateT (PA.parse header) upstream+ go hdr rest++ go mhdr rest+ | Nothing <- mhdr = return $ Pure rest+ | Just (Left err) <- mhdr = error $ show err+ | Just (Right hdr) <- mhdr+ , Just (Right len) <- lookupField hdr 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 hdr $ fmap loop $ produceBody rest++-- | Iterate over the 'Record's in a WARC archive+iterRecords :: forall m a. Monad m+ => (forall b. Record m b -> m b) -- ^ the action to run on each 'Record'+ -> Warc m a -- ^ the 'Warc' file+ -> m (Producer BS.ByteString m a) -- ^ returns any leftover data+iterRecords f warc = iterT iter warc+ where+ 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 leftover data+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++-- | Encode a 'Record' in WARC format.+encodeRecord :: Monad m => Record m a -> Producer BS.ByteString m a+encodeRecord (Record hdr content) = do+ PBS.fromLazy $ BB.toLazyByteString $ encodeHeader hdr+ content
+ src/Data/Warc/Header.hs view
@@ -0,0 +1,391 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}++module Data.Warc.Header+ ( -- * Parsing+ header+ -- * Encoding+ , encodeHeader+ -- * WARC Version+ , Version(..)+ , warc0_16+ -- * Types+ , RecordHeader(..)+ , WarcType(..)+ , RecordId(..)+ , TruncationReason(..)+ , Digest(..)+ , Uri(..)+ -- * Header field types+ , Field(..)+ , FieldName(..)+ , field+ , lookupField+ , addField+ , mapField+ , rawField+ -- ** Standard fields+ , warcRecordId+ , contentLength+ , warcDate+ , warcType+ , contentType+ , warcConcurrentTo+ , warcBlockDigest+ , warcPayloadDigest+ , warcIpAddress+ , warcRefersTo+ , warcTargetUri+ , warcTruncated+ , warcWarcinfoID+ , warcFilename+ , warcProfile+ , warcSegmentNumber+ , warcSegmentTotalLength+ -- * Lenses+ , recWarcVersion, recHeaders+ ) where++import Control.Applicative+import Control.Monad (void, guard)+import Data.Maybe (catMaybes)+import Data.Monoid ((<>))+import Data.Time.Clock+import Data.Time.Format+import Data.Char (ord)+import Data.String (IsString)++import Data.Attoparsec.ByteString.Char8 as A+import qualified Data.Attoparsec.ByteString.Lazy as AL+import qualified Data.HashMap.Strict as HM+import Data.Hashable (Hashable(..))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Lazy as TL+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Builder as BB++import Control.Lens++withName :: String -> Parser a -> Parser a+withName name parser = parser <?> name++data Version = Version {versionMajor, versionMinor :: !Int}+ deriving (Show, Read, Eq, Ord)++warc0_16 :: Version+warc0_16 = Version 0 16++version :: Parser Version+version = withName "version" $ do+ "WARC/"+ major <- decimal+ char '.'+ minor <- decimal+ return (Version major minor)++newtype FieldName = FieldName {getFieldName :: Text}+ deriving (Show, Read, IsString)++instance Hashable FieldName where+ hashWithSalt salt (FieldName t) = hashWithSalt salt (T.toCaseFold t)++instance Eq FieldName where+ FieldName a == FieldName b = T.toCaseFold a == T.toCaseFold b++instance Ord FieldName where+ FieldName a `compare` FieldName b = T.toCaseFold a `compare` T.toCaseFold b++separators :: String+separators = "()<>@,;:\\\"/[]?={}"++crlf :: Parser ()+crlf = void $ string "\r\n"++token :: Parser ByteString+token = takeTill (inClass $ separators++" \t\n\r")++utf8Token :: Parser Text+utf8Token = TE.decodeUtf8 <$> token++ord' = fromIntegral . ord++text :: Parser Text+text = do+ let content :: TL.Text -> Parser TL.Text+ content accum = do+ satisfy (isHorizontalSpace . ord')+ c <- takeTill (isEndOfLine . ord')+ endOfLine+ continuation (accum <> TL.fromStrict (TE.decodeUtf8 c))+ continuation :: TL.Text -> Parser TL.Text+ continuation accum = content accum <|> return accum+ firstLine <- takeTill (isEndOfLine . ord')+ endOfLine+ TL.toStrict <$> continuation (TL.fromStrict $ TE.decodeUtf8 firstLine)++quotedString :: Parser Text+quotedString = do+ char '"'+ c <- TE.decodeUtf8 <$> takeTill (== '"')+ char '"'+ return c++data WarcType = WarcInfo+ | Response+ | Resource+ | Request+ | Metadata+ | Revisit+ | Conversion+ | Continuation+ | FutureType !Text+ deriving (Show, Read, Ord, Eq)++parseWarcType :: Parser WarcType+parseWarcType = choice+ [ "warcinfo" *> pure WarcInfo+ , "response" *> pure Response+ , "resource" *> pure Resource+ , "request" *> pure Request+ , "metadata" *> pure Metadata+ , "revisit" *> pure Revisit+ , "conversion" *> pure Conversion+ , "continuation" *> pure Continuation+ , FutureType <$> utf8Token+ ]++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 $ 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+ | TruncUnspecified+ | TruncOther !Text+ deriving (Show, Read, Ord, Eq)++truncationReason :: Parser TruncationReason+truncationReason = choice+ [ "length" *> pure TruncLength+ , "time" *> pure TruncTime+ , "disconnect" *> pure TruncDisconnect+ , "unspecified" *> pure TruncUnspecified+ , 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)++digest :: Parser Digest+digest = do+ algo <- token <* char ':'+ hash <- token+ return $ Digest algo hash++encodeDigest :: Digest -> BB.Builder+encodeDigest (Digest algo hash) =+ BB.byteString algo <> ":" <> BB.byteString hash++date :: Parser UTCTime+date = do+ s <- takeTill isSpace+ 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 (FieldName, BSL.ByteString)+warcField = withName "field" $ do+ peekChar' >>= guard . not . isSpace+ fieldName <- FieldName . TE.decodeUtf8 <$> A.takeTill (== ':')+ char ':'+ skipSpace+ v0 <- takeLine+ endOfLine+ let continuation :: BB.Builder -> Parser BB.Builder+ continuation v = do+ c <- peekChar+ case c of+ Just c' | isHorizontalSpace (fromIntegral $ ord c') -> do+ v' <- takeLine+ endOfLine+ continuation (v <> BB.byteString v')+ _ -> return v+ v1 <- continuation (BB.byteString v0)+ return (fieldName, BB.toLazyByteString v1)++-- | Take the rest of the line (but leaving the newline character unparsed).+takeLine :: Parser BS.ByteString+takeLine = A.takeTill (isEndOfLine . ord')++data RecordHeader = RecordHeader { _recWarcVersion :: Version+ , _recHeaders :: HM.HashMap FieldName BSL.ByteString+ }+ deriving (Show)++makeLenses ''RecordHeader++-- | A lens-y means of querying 'Field's.+field :: Field a -> Traversal' RecordHeader a+field fld = recHeaders . ix (fieldName fld) . parsedField fld++parsedField :: Field a -> Prism' BSL.ByteString a+parsedField fld = prism' to from+ where+ from bs = case AL.parse (decode fld) bs of+ AL.Fail _ _ _ -> Nothing+ AL.Done _ x -> Just x+ to = BB.toLazyByteString . encode fld++addField :: Field a -> a -> RecordHeader -> RecordHeader+addField fld v =+ recHeaders . at (fieldName fld) .~ Just (BB.toLazyByteString $ encode fld v)++-- | A WARC header+header :: Parser RecordHeader+header = withName "header" $ do+ skipSpace+ ver <- version <* endOfLine+ fields <- fmap HM.fromList <$> withName "fields" $ many $ warcField+ endOfLine+ return $ RecordHeader ver fields++encodeHeader :: RecordHeader -> BB.Builder+encodeHeader (RecordHeader (Version maj min) flds) =+ "WARC/"<>BB.intDec maj<>"."<>BB.intDec min <> "\r\n"+ <> foldMap field (HM.toList flds)+ <> "\r\n"+ where field :: (FieldName, BSL.ByteString) -> BB.Builder+ field (FieldName fname, value) =+ TE.encodeUtf8Builder fname <> ": " <> BB.lazyByteString value <> "\r\n"++-- | Lookup the value of a field. Returns @Nothing@ if the field is not+-- present, @Just (Left err)@ in the event of a parse error, and+-- @Just (Right v)@ on success.+lookupField :: RecordHeader -> Field a -> Maybe (Either String a)+lookupField (RecordHeader {_recHeaders=headers}) fld+ | Just v <- HM.lookup (fieldName fld) headers+ = case AL.parse (decode fld) v of+ AL.Fail _ _ err -> Just $ Left err+ AL.Done _ x -> Just $ Right x+ | otherwise+ = Nothing++data Field a = Field { fieldName :: FieldName+ , encode :: a -> BB.Builder+ , decode :: Parser a+ }++mapField :: (a -> b) -> (b -> a) -> Field a -> Field b+mapField f g (Field fieldName encode decode) =+ Field fieldName (encode . g) (f <$> decode)++warcRecordId :: Field RecordId+warcRecordId = Field "WARC-Record-ID" encodeRecordId recordId++contentLength :: Field Integer+contentLength = Field "Content-Length" BB.integerDec decimal++warcDate :: Field UTCTime+warcDate = Field "WARC-Date" encodeDate date++warcType :: Field WarcType+warcType = Field "WARC-Type" encodeWarcType parseWarcType++contentType :: Field BS.ByteString+contentType = Field "Content-Type" BB.byteString (takeTill (isEndOfLine . ord'))++warcConcurrentTo :: Field RecordId+warcConcurrentTo = Field "WARC-Concurrent-To" encodeRecordId recordId++warcBlockDigest :: Field Digest+warcBlockDigest = Field "WARC-Block-Digest" encodeDigest digest++warcPayloadDigest :: Field Digest+warcPayloadDigest = Field "WARC-Payload-Digest" encodeDigest digest++warcIpAddress :: Field BS.ByteString+warcIpAddress = Field "WARC-IP-Address" BB.byteString (takeTill (isEndOfLine . ord'))++warcRefersTo :: Field Uri+warcRefersTo = Field "WARC-Refers-To" encodeUri uri++warcTargetUri :: Field Uri+warcTargetUri = Field "WARC-Target-URI" encodeUri laxUri++warcTruncated :: Field TruncationReason+warcTruncated = Field "WARC-Truncated" encodeTruncationReason truncationReason++warcWarcinfoID :: Field RecordId+warcWarcinfoID = Field "WARC-Warcinfo-ID" encodeRecordId recordId++warcFilename :: Field T.Text+warcFilename = Field "WARC-Filename"(quoted . encodeText) (text <|> quotedString)++warcProfile :: Field Uri+warcProfile = Field "WARC-Profile" encodeUri uri++warcSegmentNumber :: Field Integer+warcSegmentNumber = Field "WARC-Segment-Number" BB.integerDec decimal++warcSegmentTotalLength :: Field Integer+warcSegmentTotalLength = Field "WARC-Segment-Total-Length" BB.integerDec decimal++rawField :: FieldName -> Field BSL.ByteString+rawField fname = Field fname BB.lazyByteString takeLazyByteString++quoted x = q <> x <> q+ where q = BB.char7 '"'+
warc.cabal view
@@ -1,5 +1,5 @@ name: warc-version: 0.3.1+version: 1.0.1 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,13 +19,16 @@ library exposed-modules: Data.Warc, Data.Warc.Header other-extensions: RankNTypes, OverloadedStrings, TemplateHaskell- build-depends: base >=4.8 && <4.10,+ hs-source-dirs: src+ build-depends: base >=4.8 && <4.11, pipes >=4.1 && <4.3, attoparsec >=0.12 && <0.14,+ unordered-containers >=0.2 && <0.3,+ hashable >=1.2 && <1.3, bytestring >=0.10 && <0.11, pipes-bytestring >=2.1 && <2.2, transformers >=0.4 && <0.6,- lens >=4.7 && <4.15,+ lens >=4.7 && <4.16, pipes-attoparsec >=0.5 && <0.6, free >=4.10 && <4.13, errors >=1.4 && <3.0,