warc (empty) → 0.1.1.1
raw patch · 5 files changed
+376/−0 lines, 5 filesdep +attoparsecdep +basedep +bytestringsetup-changed
Dependencies added: attoparsec, base, bytestring, either, errors, free, lens, pipes, pipes-attoparsec, pipes-bytestring, text, time, transformers
Files
- Data/Warc.hs +68/−0
- Data/Warc/Header.hs +241/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- warc.cabal +35/−0
+ Data/Warc.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE RankNTypes #-}++module Data.Warc+ ( Record(..)+ , Warc(..)+ , parseWarc+ , iterRecords+ ) where++import Data.Char (ord)+import Pipes (Producer, yield)+import qualified Pipes.ByteString as PBS+import Control.Lens+import qualified Pipes.Attoparsec as PA+import qualified Data.ByteString as BS+import Data.ByteString (ByteString)+import Control.Monad (void)+import Control.Monad.Trans.Class+import Control.Monad.Trans.Either+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+ }++instance Monad m => Functor (Record m) where+ fmap f (Record ver hdr r) = Record ver 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 ()))++parseWarc :: (Functor m, Monad m) => Producer ByteString m () -> Warc m+parseWarc = Warc . 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+ 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++iterRecords :: Monad m => (forall a. Record m a -> m a) -> Warc m -> m (Producer BS.ByteString m ())+iterRecords f (Warc free) = go free+ where+ go (FreeT action) = action >>= \next -> do+ case next of+ Pure a -> return a+ Free record -> do+ rest <- f record+ go rest
+ Data/Warc/Header.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Warc.Header+ ( Version(..)+ , WarcType (..)+ , RecordId (..)+ , TruncationReason (..)+ , Digest (..)+ , header+ -- * Header field types+ , Field (..)+ -- ** Prisms+ , _WarcRecordId+ , _ContentLength+ , _WarcDate+ , _WarcType+ , _ContentType+ , _WarcConcurrentTo+ , _WarcBlockDigest+ , _WarcPayloadDigest+ , _WarcIpAddress+ , _WarcRefersTo+ , _WarcTargetUri+ , _WarcTruncated+ , _WarcWarcinfoId+ , _WarcFilename+ , _WarcProfile+ , _WarcIdentifiedPayloadType+ , _WarcSegmentNumber+ , _WarcSegmentOriginId+ , _WarcSegmentTotalLength+ ) 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 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+ ]+ +newtype RecordId = RecordId ByteString+ deriving (Show, Read, Eq, Ord)++uri :: Parser ByteString+uri = do+ char '<'+ s <- takeTill (== '>')+ char '>'+ return s++recordId :: Parser RecordId+recordId = RecordId <$> uri++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+ ]++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++data Field = WarcRecordId !RecordId+ | ContentLength !Integer+ | WarcDate !UTCTime+ | WarcType !WarcType+ | ContentType !ByteString+ | WarcConcurrentTo [RecordId]+ | WarcBlockDigest !Digest+ | WarcPayloadDigest !Digest+ | WarcIpAddress !ByteString+ | WarcRefersTo !ByteString+ | WarcTargetUri !ByteString+ | WarcTruncated !TruncationReason+ | WarcWarcinfoId !RecordId+ | WarcFilename !Text+ | WarcProfile !ByteString+ | WarcIdentifiedPayloadType !ByteString+ | WarcSegmentNumber !Integer+ | WarcSegmentOriginId !ByteString+ | WarcSegmentTotalLength !Integer+ deriving (Show, Read)++makePrisms ''Field++date :: Parser UTCTime+date = do+ s <- takeTill isSpace+ parseTimeM False defaultTimeLocale fmt (BS.unpack s)+ where fmt = 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 <$> many1 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-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)+ ]++-- | A WARC header+header :: Parser (Version, [Field])+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)
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Ben Gamari++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Ben Gamari nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ warc.cabal view
@@ -0,0 +1,35 @@+name: warc+version: 0.1.1.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+license: BSD3+license-file: LICENSE+author: Ben Gamari+maintainer: ben@smart-cactus.org+copyright: (c) 2015 Ben Gamari+category: Data+build-type: Simple+cabal-version: >=1.10++source-repository head+ type: git+ location: git://github.com/bgamari/warc++library+ exposed-modules: Data.Warc, Data.Warc.Header+ other-extensions: RankNTypes, OverloadedStrings, TemplateHaskell+ build-depends: base >=4.8 && <4.9,+ 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,+ 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+ default-language: Haskell2010