diff --git a/Data/Warc.hs b/Data/Warc.hs --- a/Data/Warc.hs +++ b/Data/Warc.hs @@ -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 diff --git a/Data/Warc/Header.hs b/Data/Warc/Header.hs --- a/Data/Warc/Header.hs +++ b/Data/Warc/Header.hs @@ -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 '"' diff --git a/WarcExport.hs b/WarcExport.hs new file mode 100644 --- /dev/null +++ b/WarcExport.hs @@ -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 diff --git a/warc.cabal b/warc.cabal --- a/warc.cabal +++ b/warc.cabal @@ -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